CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-19 00:15:39 +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 fetch-depth: 0
- name: Prepare container with all dependencies - name: Prepare container with all dependencies
run: git archive HEAD | docker build - --target dev-build-context run: git archive HEAD | docker build - --target dev-build-context
- name: Escape slashes in IMAGE_TAG (to avoid Docker issues) - name: Escape chars in IMAGE_TAG (to avoid Docker issues)
run: echo "IMAGE_TAG=${IMAGE_TAG////--}" >> $GITHUB_ENV run: sed 's/[^a-zA-Z0-9-]/-/g; s/^/IMAGE_TAG=/' <<<"${IMAGE_TAG}" >> $GITHUB_ENV
- name: Run builds, checks and tests - name: Run builds, checks and tests
run: git archive HEAD | docker build - --force-rm -t "catalalang/catala-build:${IMAGE_TAG}" run: git archive HEAD | docker build - --force-rm -t "catalalang/catala-build:${IMAGE_TAG}"
- name: Cleanup Docker image - name: Cleanup Docker image

6
Makefile
View File

@ -12,7 +12,7 @@ export
# Dependencies # Dependencies
########################################## ##########################################
EXECUTABLES = groff python3 colordiff node node npm ninja pandoc EXECUTABLES = groff python3 node npm ninja pandoc
K := $(foreach exec,$(EXECUTABLES),\ K := $(foreach exec,$(EXECUTABLES),\
$(if $(shell which $(exec)),some string,$(warning [WARNING] No "$(exec)" executable found. \ $(if $(shell which $(exec)),some string,$(warning [WARNING] No "$(exec)" executable found. \
Please install this executable for everything to work smoothly))) Please install this executable for everything to work smoothly)))
@ -315,10 +315,10 @@ CLERK=$(CLERK_BIN) --exe $(CATALA_BIN) \
.FORCE: .FORCE:
test_suite: .FORCE compiler test_suite: .FORCE install
@$(MAKE) -C tests pass_all_tests @$(MAKE) -C tests pass_all_tests
test_examples: .FORCE compiler test_examples: .FORCE install
@$(MAKE) -C examples pass_all_tests @$(MAKE) -C examples pass_all_tests
#> tests : Run interpreter 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 let dirs = Sys.readdir dirname in
Array.fast_sort String.compare dirs; Array.fast_sort String.compare dirs;
dirs dirs
with Sys_error _ -> Array.make 0 "" with Sys_error _ -> [||]
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
(** Given a file, looks in the relative [output] directory if there are files (** Given a file, looks in the relative [output] directory if there are files
with the same base name that contain expected outputs for different *) with the same base name that contain expected outputs for different *)
@ -477,7 +390,7 @@ let collect_inline_ninja_builds
(ninja : ninja) (ninja : ninja)
(tested_file : string) (tested_file : string)
(reset_test_outputs : bool) : (string * ninja) option = (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 else
let ninja = let ninja =
let vars = [Var.(name tested_file), Nj.Expr.Lit tested_file] in let vars = [Var.(name tested_file), Nj.Expr.Lit tested_file] in
@ -609,74 +522,6 @@ let add_root_test_build
ninja.builds; 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}*) (**{1 Running}*)
let run_file let run_file
@ -688,7 +533,7 @@ let run_file
String.concat " " String.concat " "
(List.filter (List.filter
(fun s -> s <> "") (fun s -> s <> "")
[catala_exe; catala_opts; "-s " ^ scope; "Interpret"; file]) [catala_exe; "Interpret"; file; catala_opts; "-s " ^ scope])
in in
Message.emit_debug "Running: %s" command; Message.emit_debug "Running: %s" command;
Sys.command command Sys.command command
@ -950,7 +795,7 @@ let driver
| "runtest" -> ( | "runtest" -> (
match files_or_folders with match files_or_folders with
| [f] -> | [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)); (List.filter (( <> ) "") (String.split_on_char ' ' catala_opts));
0 0
| _ -> Message.raise_error "Please specify a single catala file to test") | _ -> 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 cmdliner
re re
ocolor) ocolor)
(modules clerk_driver)) (modules clerk_runtest clerk_driver))
(rule (rule
(target custom_linking.sexp) (target custom_linking.sexp)

14
compiler/catala_utils/map.ml
View File

@ -29,6 +29,10 @@ end
module type S = sig module type S = sig
include Stdlib.Map.S 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 keys : 'a t -> key list
val values : 'a t -> 'a list val values : 'a t -> 'a list
val of_list : (key * 'a) list -> 'a t val of_list : (key * 'a) list -> 'a t
@ -70,6 +74,16 @@ end
module Make (Ord : OrderedType) : S with type key = Ord.t = struct module Make (Ord : OrderedType) : S with type key = Ord.t = struct
include Stdlib.Map.Make (Ord) 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 keys t = fold (fun k _ acc -> k :: acc) t [] |> List.rev
let values t = fold (fun _ v acc -> v :: 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 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 val hash : t -> int
module Set : Set.S with type elt = t 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 module Map : Map.S with type key = t
end end
@ -43,7 +42,7 @@ module Make (X : Info) () : Id with type info = X.info = struct
module Ordering = struct module Ordering = struct
type t = { id : int; info : X.info } 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 equal x y = Int.equal x.id y.id
let format ppf t = X.format ppf t.info let format ppf t = X.format ppf t.info
end end
@ -59,15 +58,14 @@ module Make (X : Info) () : Id with type info = X.info = struct
{ id = !counter; info } { id = !counter; info }
let get_info (uid : t) : X.info = uid.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 let hash (x : t) : int = x.id
module Set = Set.Make (Ordering) module Set = Set.Make (Ordering)
module Map = Map.Make (Ordering) module Map = Map.Make (Ordering)
module SetLabels = MoreLabels.Set.Make (Ordering)
module MapLabels = MoreLabels.Map.Make (Ordering)
end end
(* - Raw idents - *)
module MarkedString = struct module MarkedString = struct
type info = string Mark.pos type info = string Mark.pos
@ -78,3 +76,54 @@ module MarkedString = struct
end end
module Gen () = Make (MarkedString) () 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 val hash : t -> int
module Set : Set.S with type elt = t 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 module Map : Map.S with type key = t
end end
@ -61,3 +60,36 @@ module Make (X : Info) () : Id with type info = X.info
module Gen () : Id with type info = MarkedString.info module Gen () : Id with type info = MarkedString.info
(** Shortcut for creating a kind of uids over marked strings *) (** 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; 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 = { type 'm scope_sig_ctx = {
scope_sig_local_vars : scope_var_ctx list; (** List of scope variables *) 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_scope_ref : 'm scope_ref;
scope_sig_input_var : 'm Ast.expr Var.t; (** Var or external representing the scope *)
(** Var representing the scope input inside the scope func *)
scope_sig_input_struct : StructName.t; (** Scope input *) scope_sig_input_struct : StructName.t; (** Scope input *)
scope_sig_output_struct : StructName.t; (** Scope output *) scope_sig_output_struct : StructName.t; (** Scope output *)
scope_sig_in_fields : scope_input_var_ctx ScopeVar.Map.t; scope_sig_in_fields : scope_input_var_ctx ScopeVar.Map.t;
(** Mapping between the input scope variables and the input struct fields. *) (** 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 = { type 'm ctx = {
structs : struct_ctx; decl_ctx : decl_ctx;
enums : enum_ctx;
scope_name : ScopeName.t option; scope_name : ScopeName.t option;
scopes_parameters : 'm scope_sigs_ctx; scopes_parameters : 'm scope_sigs_ctx;
toplevel_vars : ('m Ast.expr Var.t * naked_typ) TopdefName.Map.t; 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 let pos_mark_as e = pos_mark (Mark.get e) in
pos_mark, pos_mark_as 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 let merge_defaults
~(is_func : bool) ~(is_func : bool)
(caller : (dcalc, 'm) boxed_gexpr) (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 let m = Mark.get e in
match Mark.remove e with match Mark.remove e with
| EMatch { e = e1; name; cases = e_cases } -> | 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 = let d_cases, remaining_e_cases =
(* FIXME: these checks should probably be moved to a better place *) (* FIXME: these checks should probably be moved to a better place *)
EnumConstructor.Map.fold EnumConstructor.Map.fold
(fun constructor _ (d_cases, e_cases) -> (fun constructor _ (d_cases, e_cases) ->
let case_e = let case_e =
try EnumConstructor.Map.find constructor e_cases try EnumConstructor.Map.find constructor e_cases
with Not_found -> with EnumConstructor.Map.Not_found _ ->
Message.raise_spanned_error (Expr.pos e) Message.raise_spanned_error (Expr.pos e)
"The constructor %a of enum %a is missing from this pattern \ "The constructor %a of enum %a is missing from this pattern \
matching" matching"
@ -230,10 +239,10 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
Format.fprintf fmt ", ")) Format.fprintf fmt ", "))
remaining_e_cases; remaining_e_cases;
let e1 = translate_expr ctx e1 in 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 } -> | EScopeCall { scope; args } ->
let pos = Expr.mark_pos m in 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 = let in_var_map =
ScopeVar.Map.merge ScopeVar.Map.merge
(fun var_name (str_field : scope_input_var_ctx option) expr -> (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_var_map StructField.Map.empty
in in
let arg_struct = 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 in
let called_func = let called_func =
tag_with_log_entry let m = mark_tany m pos in
(Expr.evar sc_sig.scope_sig_scope_var (mark_tany m pos)) let e =
BeginCall 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"] [ScopeName.get_info scope; Mark.add (Expr.pos e) "direct"]
in in
let single_arg = 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 (* result_eta_expanded = { struct_output_function_field = lambda x -> log
(struct_output.struct_output_function_field x) ... } *) (struct_output.struct_output_function_field x) ... } *)
let result_eta_expanded = let result_eta_expanded =
Expr.estruct sc_sig.scope_sig_output_struct Expr.estruct ~name:sc_sig.scope_sig_output_struct
(StructField.Map.mapi ~fields:
(fun field typ -> (StructField.Map.mapi
let original_field_expr = (fun field typ ->
Expr.estructaccess let original_field_expr =
(Expr.make_var result_var Expr.estructaccess
(Expr.with_ty m ~e:
(TStruct sc_sig.scope_sig_output_struct, Expr.pos e))) (Expr.make_var result_var
field sc_sig.scope_sig_output_struct (Expr.with_ty m typ) (Expr.with_ty m
in (TStruct sc_sig.scope_sig_output_struct, Expr.pos e)))
match Mark.remove typ with ~field ~name:sc_sig.scope_sig_output_struct
| TArrow (ts_in, t_out) -> (Expr.with_ty m typ)
(* 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 in
let f_markings = match Mark.remove typ with
[ScopeName.get_info scope; StructField.get_info field] | TArrow (ts_in, t_out) ->
in (* Here the output scope struct field is a function so we
Expr.make_abs eta-expand it and insert logging instructions. Invariant:
(Array.of_list params_vars) works because there is no partial evaluation. *)
(tag_with_log_entry let params_vars =
(tag_with_log_entry ListLabels.mapi ts_in ~f:(fun i _ ->
(Expr.eapp Var.make ("param" ^ string_of_int i))
(tag_with_log_entry original_field_expr BeginCall in
f_markings) let f_markings =
(ListLabels.mapi (List.combine params_vars ts_in) [ScopeName.get_info scope; StructField.get_info field]
~f:(fun i (param_var, t_in) -> in
tag_with_log_entry Expr.make_abs
(Expr.make_var param_var (Expr.with_ty m t_in)) (Array.of_list params_vars)
(VarDef (tag_with_log_entry
{ (tag_with_log_entry
log_typ = Mark.remove t_in; (Expr.eapp
log_io_output = false; (tag_with_log_entry original_field_expr BeginCall
log_io_input = OnlyInput; f_markings)
}) (ListLabels.mapi (List.combine params_vars ts_in)
(f_markings ~f:(fun i (param_var, t_in) ->
@ [ tag_with_log_entry
Mark.add (Expr.pos e) (Expr.make_var param_var
("input" ^ string_of_int i); (Expr.with_ty m t_in))
]))) (VarDef
(Expr.with_ty m t_out)) {
(VarDef log_typ = Mark.remove t_in;
{ log_io_output = false;
log_typ = Mark.remove t_out; log_io_input = OnlyInput;
log_io_output = true; })
log_io_input = NoInput; (f_markings
}) @ [
(f_markings @ [Mark.add (Expr.pos e) "output"])) Mark.add (Expr.pos e)
EndCall f_markings) ("input" ^ string_of_int i);
ts_in (Expr.pos e) ])))
| _ -> original_field_expr) (Expr.with_ty m t_out))
(StructName.Map.find sc_sig.scope_sig_output_struct ctx.structs)) (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)) (Expr.with_ty m (TStruct sc_sig.scope_sig_output_struct, Expr.pos e))
in in
(* Here we have to go through an if statement that records a decision being (* 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 match ctx.scope_name, Mark.remove f with
| Some sname, ELocation loc -> ( | Some sname, ELocation loc -> (
match loc with match loc with
| ScopelangScopeVar (v, _) -> | ScopelangScopeVar { name = v, _; _ } ->
[ScopeName.get_info sname; ScopeVar.get_info v] [ScopeName.get_info sname; ScopeVar.get_info v]
| SubScopeVar (s, _, (v, _)) -> | SubScopeVar { scope; var = v, _; _ } ->
[ScopeName.get_info s; ScopeVar.get_info v] [ScopeName.get_info scope; ScopeVar.get_info v]
| ToplevelVar _ -> []) | ToplevelVar _ -> [])
| _ -> [] | _ -> []
in in
@ -453,8 +473,8 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
in in
let new_args = List.map (translate_expr ctx) args in let new_args = List.map (translate_expr ctx) args in
let input_typs, output_typ = let input_typs, output_typ =
(* NOTE: this is a temporary solution, it works because it's assume that (* NOTE: this is a temporary solution, it works because it's assumed that
all function calls are from scope variable. However, this will change all function calls are from scope variables. However, this will change
-- for more information see -- for more information see
https://github.com/CatalaLang/catala/pull/280#discussion_r898851693. *) https://github.com/CatalaLang/catala/pull/280#discussion_r898851693. *)
let retrieve_in_and_out_typ_or_any var vars = 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 | _ -> ListLabels.map new_args ~f:(fun _ -> TAny), TAny
in in
match Mark.remove f with match Mark.remove f with
| ELocation (ScopelangScopeVar var) -> | ELocation (ScopelangScopeVar { name = var }) ->
retrieve_in_and_out_typ_or_any var ctx.scope_vars retrieve_in_and_out_typ_or_any var ctx.scope_vars
| ELocation (SubScopeVar (_, sname, var)) -> | ELocation (SubScopeVar { alias; var; _ }) ->
ctx.subscope_vars ctx.subscope_vars
|> SubScopeName.Map.find (Mark.remove sname) |> SubScopeName.Map.find (Mark.remove alias)
|> retrieve_in_and_out_typ_or_any var |> retrieve_in_and_out_typ_or_any var
| ELocation (ToplevelVar tvar) -> ( | ELocation (ToplevelVar { name }) -> (
let _, typ = TopdefName.Map.find (Mark.remove tvar) ctx.toplevel_vars in let decl_ctx =
match typ with 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 | TArrow (tin, (tout, _)) -> List.map Mark.remove tin, tout
| _ -> | _ ->
Message.raise_spanned_error (Expr.pos e) 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 Expr.edefault
(List.map (translate_expr ctx) excepts) (List.map (translate_expr ctx) excepts)
(translate_expr ctx just) (translate_expr ctx cons) m (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 let v, _, _ = ScopeVar.Map.find (Mark.remove a) ctx.scope_vars in
Expr.evar v m Expr.evar v m
| ELocation (SubScopeVar (_, s, a)) -> ( | ELocation (SubScopeVar { alias = s; var = a; _ }) -> (
try try
let v, _, _ = let v, _, _ =
ScopeVar.Map.find (Mark.remove a) ScopeVar.Map.find (Mark.remove a)
(SubScopeName.Map.find (Mark.remove s) ctx.subscope_vars) (SubScopeName.Map.find (Mark.remove s) ctx.subscope_vars)
in in
Expr.evar v m Expr.evar v m
with Not_found -> with ScopeVar.Map.Not_found _ | SubScopeName.Map.Not_found _ ->
Message.raise_multispanned_error Message.raise_multispanned_error
[ [
Some "Incriminated variable usage:", Expr.pos e; 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?" %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) ScopeVar.format (Mark.remove a)
SubScopeName.format (Mark.remove s)) SubScopeName.format (Mark.remove s))
| ELocation (ToplevelVar v) -> | ELocation (ToplevelVar { name }) ->
let v, _ = TopdefName.Map.find (Mark.remove v) ctx.toplevel_vars in let path = TopdefName.path (Mark.remove name) in
Expr.evar v m 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 } -> | EOp { op = Add_dat_dur _; tys } ->
Expr.eop (Add_dat_dur ctx.date_rounding) tys m Expr.eop (Add_dat_dur ctx.date_rounding) tys m
| EOp { op; tys } -> Expr.eop (Operator.translate op) tys m | EOp { op; tys } -> Expr.eop (Operator.translate op) tys m
| ( EVar _ | EAbs _ | ELit _ | EExternal _ | EStruct _ | EStructAccess _ | ( EVar _ | EAbs _ | ELit _ | EStruct _ | EStructAccess _ | ETuple _
| ETuple _ | ETupleAccess _ | EInj _ | EEmptyError | EErrorOnEmpty _ | ETupleAccess _ | EInj _ | EEmptyError | EErrorOnEmpty _ | EArray _
| EArray _ | EIfThenElse _ ) as e -> | EIfThenElse _ ) as e ->
Expr.map ~f:(translate_expr ctx) (e, m) Expr.map ~f:(translate_expr ctx) (e, m)
(** The result of a rule translation is a list of assignment, with variables and (** 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 Ast.expr scope_body_expr Bindlib.box)
* 'm ctx = * 'm ctx =
match rule with 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 pos_mark, pos_mark_as = pos_mark_mk e in
let a_name = ScopeVar.get_info (Mark.remove a) in let a_name = ScopeVar.get_info (Mark.remove a) in
let a_var = Var.make (Mark.remove a_name) in let a_var = Var.make (Mark.remove a_name) in
@ -615,7 +641,7 @@ let translate_rule
ctx.scope_vars; ctx.scope_vars;
} ) } )
| Definition | Definition
( (SubScopeVar (_subs_name, subs_index, subs_var), var_def_pos), ( (SubScopeVar { alias = subs_index; var = subs_var; _ }, var_def_pos),
tau, tau,
a_io, a_io,
e ) -> e ) ->
@ -682,7 +708,11 @@ let translate_rule
could be made more specific to avoid this case, but the added complexity could be made more specific to avoid this case, but the added complexity
didn't seem worth it *) didn't seem worth it *)
| Call (subname, subindex, m) -> | 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_vars = subscope_sig.scope_sig_local_vars in
let all_subscope_input_vars = let all_subscope_input_vars =
List.filter List.filter
@ -698,17 +728,23 @@ let translate_rule
Mark.remove var_ctx.scope_var_io.Desugared.Ast.io_output) Mark.remove var_ctx.scope_var_io.Desugared.Ast.io_output)
all_subscope_vars all_subscope_vars
in 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_input_struct = subscope_sig.scope_sig_input_struct in
let called_scope_return_struct = subscope_sig.scope_sig_output_struct in let called_scope_return_struct = subscope_sig.scope_sig_output_struct in
let subscope_vars_defined = let subscope_vars_defined =
try SubScopeName.Map.find subindex ctx.subscope_vars try SubScopeName.Map.find subindex ctx.subscope_vars
with Not_found -> ScopeVar.Map.empty with SubScopeName.Map.Not_found _ -> ScopeVar.Map.empty
in in
let subscope_var_not_yet_defined subvar = let subscope_var_not_yet_defined subvar =
not (ScopeVar.Map.mem subvar subscope_vars_defined) not (ScopeVar.Map.mem subvar subscope_vars_defined)
in in
let pos_call = Mark.get (SubScopeName.get_info subindex) in
let subscope_args = let subscope_args =
List.fold_left List.fold_left
(fun acc (subvar : scope_var_ctx) -> (fun acc (subvar : scope_var_ctx) ->
@ -734,7 +770,7 @@ let translate_rule
StructField.Map.empty all_subscope_input_vars StructField.Map.empty all_subscope_input_vars
in in
let subscope_struct_arg = 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) (mark_tany m pos_call)
in in
let all_subscope_output_vars_dcalc = let all_subscope_output_vars_dcalc =
@ -750,9 +786,7 @@ let translate_rule
all_subscope_output_vars all_subscope_output_vars
in in
let subscope_func = let subscope_func =
tag_with_log_entry tag_with_log_entry scope_dcalc_ref BeginCall
(Expr.make_var scope_dcalc_var (mark_tany m pos_call))
BeginCall
[ [
sigma_name, pos_sigma; sigma_name, pos_sigma;
SubScopeName.get_info subindex; SubScopeName.get_info subindex;
@ -790,7 +824,7 @@ let translate_rule
(fun (var_ctx, v) next -> (fun (var_ctx, v) next ->
let field = let field =
ScopeVar.Map.find var_ctx.scope_var_name ScopeVar.Map.find var_ctx.scope_var_name
subscope_sig.scope_sig_out_fields scope_sig_decl.out_struct_fields
in in
Bindlib.box_apply2 Bindlib.box_apply2
(fun next r -> (fun next r ->
@ -849,6 +883,7 @@ let translate_rule
let translate_rules let translate_rules
(ctx : 'm ctx) (ctx : 'm ctx)
(scope_name : ScopeName.t)
(rules : 'm Scopelang.Ast.rule list) (rules : 'm Scopelang.Ast.rule list)
((sigma_name, pos_sigma) : Uid.MarkedString.info) ((sigma_name, pos_sigma) : Uid.MarkedString.info)
(mark : 'm mark) (mark : 'm mark)
@ -864,17 +899,21 @@ let translate_rules
((fun next -> next), ctx) ((fun next -> next), ctx)
rules rules
in in
let scope_sig_decl = ScopeName.Map.find scope_name ctx.decl_ctx.ctx_scopes in
let return_exp = let return_exp =
Expr.estruct scope_sig.scope_sig_output_struct Expr.estruct ~name:scope_sig.scope_sig_output_struct
(ScopeVar.Map.fold ~fields:
(fun var (dcalc_var, _, io) acc -> (ScopeVar.Map.fold
if Mark.remove io.Desugared.Ast.io_output then (fun var (dcalc_var, _, io) acc ->
let field = ScopeVar.Map.find var scope_sig.scope_sig_out_fields in if Mark.remove io.Desugared.Ast.io_output then
StructField.Map.add field let field =
(Expr.make_var dcalc_var (mark_tany mark pos_sigma)) ScopeVar.Map.find var scope_sig_decl.out_struct_fields
acc in
else acc) StructField.Map.add field
new_ctx.scope_vars StructField.Map.empty) (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) (mark_tany mark pos_sigma)
in in
( scope_lets ( scope_lets
@ -883,6 +922,8 @@ let translate_rules
(Expr.Box.lift return_exp)), (Expr.Box.lift return_exp)),
new_ctx ) new_ctx )
(* From a scope declaration and definitions, create the corresponding scope body
wrapped in the appropriate call convention. *)
let translate_scope_decl let translate_scope_decl
(ctx : 'm ctx) (ctx : 'm ctx)
(scope_name : ScopeName.t) (scope_name : ScopeName.t)
@ -890,7 +931,7 @@ let translate_scope_decl
'm Ast.expr scope_body Bindlib.box * struct_ctx = 'm Ast.expr scope_body Bindlib.box * struct_ctx =
let sigma_info = ScopeName.get_info sigma.scope_decl_name in let sigma_info = ScopeName.get_info sigma.scope_decl_name in
let scope_sig = 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 in
let scope_variables = scope_sig.scope_sig_local_vars in let scope_variables = scope_sig.scope_sig_local_vars in
let ctx = { ctx with scope_name = Some scope_name } in let ctx = { ctx with scope_name = Some scope_name } in
@ -926,12 +967,26 @@ let translate_scope_decl
| None -> AbortOnRound | None -> AbortOnRound
in in
let ctx = { ctx with date_rounding } 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_input_struct_name = scope_sig.scope_sig_input_struct in
let scope_return_struct_name = scope_sig.scope_sig_output_struct in let scope_return_struct_name = scope_sig.scope_sig_output_struct in
let pos_sigma = Mark.get sigma_info 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 = 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 scope_sig
in in
let scope_variables = let scope_variables =
@ -982,14 +1037,24 @@ let translate_scope_decl
scope_let_expr = scope_let_expr =
( EStructAccess ( EStructAccess
{ name = scope_input_struct_name; e = r; field }, { 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) (Bindlib.bind_var v next)
(Expr.Box.lift (Expr.Box.lift
(Expr.make_var scope_input_var (Expr.make_var scope_input_var (mark_tany scope_mark pos_sigma))))
(mark_tany sigma.scope_mark pos_sigma))))
scope_input_variables next scope_input_variables next
in 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 = let field_map =
List.fold_left List.fold_left
(fun acc (var_ctx, _) -> (fun acc (var_ctx, _) ->
@ -1003,16 +1068,7 @@ let translate_scope_decl
let new_struct_ctx = let new_struct_ctx =
StructName.Map.singleton scope_input_struct_name field_map StructName.Map.singleton scope_input_struct_name field_map
in in
( Bindlib.box_apply scope_body, new_struct_ctx
(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 )
let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program = let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
let defs_dependencies = Scopelang.Dependency.build_program_dep_graph prgm in 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 in
let decl_ctx = prgm.program_ctx in let decl_ctx = prgm.program_ctx in
let sctx : 'm scope_sigs_ctx = let sctx : 'm scope_sigs_ctx =
ScopeName.Map.mapi let process_scope_sig scope_name scope =
(fun scope_name scope -> let scope_path = ScopeName.path scope_name in
let scope_dvar = let scope_ref =
Var.make if scope_path = [] then
(Mark.remove let v = Var.make (Mark.remove (ScopeName.get_info scope_name)) in
(ScopeName.get_info scope.Scopelang.Ast.scope_decl_name)) Local_scope_ref v
in else
let scope_return = ScopeName.Map.find scope_name decl_ctx.ctx_scopes in External_scope_ref
let scope_input_var = (Mark.copy (ScopeName.get_info scope_name) scope_name)
Var.make (Mark.remove (ScopeName.get_info scope_name) ^ "_in") in
in let scope_info =
let scope_input_struct_name = try
StructName.fresh ScopeName.Map.find scope_name
(Mark.map (fun s -> s ^ "_in") (ScopeName.get_info scope_name)) (Program.module_ctx decl_ctx scope_path).ctx_scopes
in with ScopeName.Map.Not_found _ ->
let scope_sig_in_fields = Message.raise_spanned_error
ScopeVar.Map.filter_map (Mark.get (ScopeName.get_info scope_name))
(fun dvar (typ, vis) -> "Could not find scope %a" ScopeName.format scope_name
match Mark.remove vis.Desugared.Ast.io_input with in
| NoInput -> None let scope_sig_in_fields =
| OnlyInput | Reentrant -> (* Output fields have already been generated and added to the program
let info = ScopeVar.get_info dvar in ctx at this point, because they are visible to the user (manipulated
let s = Mark.remove info ^ "_in" in as the return type of ScopeCalls) ; but input fields are used purely
Some internally and need to be created here to implement the call
{ convention for scopes. *)
scope_input_name = StructField.fresh (s, Mark.get info); ScopeVar.Map.filter_map
scope_input_io = vis.Desugared.Ast.io_input; (fun dvar (typ, vis) ->
scope_input_typ = Mark.remove typ; match Mark.remove vis.Desugared.Ast.io_input with
}) | NoInput -> None
scope.scope_sig | OnlyInput | Reentrant ->
in let info = ScopeVar.get_info dvar in
{ let s = Mark.remove info ^ "_in" in
scope_sig_local_vars = Some
List.map
(fun (scope_var, (tau, vis)) ->
{ {
scope_var_name = scope_var; scope_input_name = StructField.fresh (s, Mark.get info);
scope_var_typ = Mark.remove tau; scope_input_io = vis.Desugared.Ast.io_input;
scope_var_io = vis; scope_input_typ = Mark.remove typ;
}) })
(ScopeVar.Map.bindings scope.scope_sig); scope.Scopelang.Ast.scope_sig
scope_sig_scope_var = scope_dvar; in
scope_sig_input_var = scope_input_var; {
scope_sig_input_struct = scope_input_struct_name; scope_sig_local_vars =
scope_sig_output_struct = scope_return.out_struct_name; List.map
scope_sig_in_fields; (fun (scope_var, (tau, vis)) ->
scope_sig_out_fields = scope_return.out_struct_fields; {
}) scope_var_name = scope_var;
prgm.Scopelang.Ast.program_scopes 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 in
let top_ctx = let top_ctx =
let toplevel_vars = let toplevel_vars =
@ -1080,8 +1192,7 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
prgm.Scopelang.Ast.program_topdefs prgm.Scopelang.Ast.program_topdefs
in in
{ {
structs = decl_ctx.ctx_structs; decl_ctx;
enums = decl_ctx.ctx_enums;
scope_name = None; scope_name = None;
scopes_parameters = sctx; scopes_parameters = sctx;
scope_vars = ScopeVar.Map.empty; 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 -> | Scopelang.Dependency.Scope scope_name ->
let scope = ScopeName.Map.find scope_name prgm.program_scopes in let scope = ScopeName.Map.find scope_name prgm.program_scopes in
let scope_body, scope_in_struct = 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 in
( { ( {
ctx with ctx with
structs = decl_ctx =
StructName.Map.union {
(fun _ _ -> assert false) ctx.decl_ctx with
ctx.structs scope_in_struct; 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 Bindlib.box_apply
(fun body -> ScopeDef (scope_name, body)) (fun body -> ScopeDef (scope_name, body))
scope_body ) scope_body )
@ -1131,7 +1254,4 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
ctx ) ctx )
in in
let items, ctx = translate_defs top_ctx defs_ordering in let items, ctx = translate_defs top_ctx defs_ordering in
{ { code_items = Bindlib.unbox items; decl_ctx = ctx.decl_ctx }
code_items = Bindlib.unbox items;
decl_ctx = { decl_ctx with ctx_structs = ctx.structs };
}

8
compiler/desugared/ast.ml
View File

@ -227,6 +227,7 @@ type program = {
program_scopes : scope ScopeName.Map.t; program_scopes : scope ScopeName.Map.t;
program_topdefs : (expr option * typ) TopdefName.Map.t; program_topdefs : (expr option * typ) TopdefName.Map.t;
program_ctx : decl_ctx; program_ctx : decl_ctx;
program_modules : program ModuleName.Map.t;
} }
let rec locations_used e : LocationSet.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 -> (fun (loc, loc_pos) acc ->
let usage = let usage =
match loc with match loc with
| DesugaredScopeVar (v, st) -> Some (ScopeDef.Var (Mark.remove v, st)) | DesugaredScopeVar { name; state } ->
| SubScopeVar (_, sub_index, sub_var) -> Some (ScopeDef.Var (Mark.remove name, state))
| SubScopeVar { alias; var; _ } ->
Some Some
(ScopeDef.SubScopeVar (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 | ToplevelVar _ -> None
in in
match usage with match usage with

1
compiler/desugared/ast.mli
View File

@ -116,6 +116,7 @@ type program = {
program_scopes : scope ScopeName.Map.t; program_scopes : scope ScopeName.Map.t;
program_topdefs : (expr option * typ) TopdefName.Map.t; program_topdefs : (expr option * typ) TopdefName.Map.t;
program_ctx : decl_ctx; program_ctx : decl_ctx;
program_modules : program ModuleName.Map.t;
} }
(** {1 Helpers} *) (** {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 -> (fun used_var g ->
let edge_from = let edge_from =
match Mark.remove used_var with match Mark.remove used_var with
| DesugaredScopeVar (v, s) -> Some (Vertex.Var (Mark.remove v, s)) | DesugaredScopeVar { name; state } ->
| SubScopeVar (_, subscope_name, _) -> Some (Vertex.Var (Mark.remove name, state))
Some (Vertex.SubScope (Mark.remove subscope_name)) | SubScopeVar { alias; _ } ->
Some (Vertex.SubScope (Mark.remove alias))
| ToplevelVar _ -> None | ToplevelVar _ -> None
(* we don't add this dependency because toplevel definitions are (* we don't add this dependency because toplevel definitions are
outside the scope *) 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 } { scope with scope_defs; scope_assertions }
let program prg = 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 = let env =
TopdefName.Map.fold ModuleName.Map.fold
(fun name (_e, ty) env -> Typing.Env.add_toplevel_var name ty env) (fun modname prg ->
prg.program_topdefs Typing.Env.add_module modname ~module_env:(build_typing_env prg))
(Typing.Env.empty prg.program_ctx) prg.program_modules (base_typing_env prg)
in in
let program_topdefs = let program_topdefs =
TopdefName.Map.map TopdefName.Map.map
@ -76,20 +107,6 @@ let program prg =
| None, ty -> None, ty) | None, ty -> None, ty)
prg.program_topdefs prg.program_topdefs
in 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 = let program_scopes =
ScopeName.Map.map (scope prg.program_ctx env) prg.program_scopes ScopeName.Map.map (scope prg.program_ctx env) prg.program_scopes
in 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: the operator suffixes for explicit typing. See {!modules:
Shared_ast.Operator} for detail. *) 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 -> fun op pos ->
let op_expr op tys = let op_expr op tys =
Expr.eop op (List.map (Mark.add pos) tys) (Untyped { pos }) 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.Neq -> assert false (* desugared already *)
| S.Concat -> op_expr Concat [TArray (TAny, pos); TArray (TAny, pos)] | 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 let op_expr op ty = Expr.eop op [Mark.add pos ty] (Untyped { pos }) in
match op with match op with
| S.Not -> op_expr Not (TLit TBool) | 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 \ "The name of this constructor has not been defined before@ (it's probably \
a typographical error)." a typographical error)."
let disambiguate_constructor let rec disambiguate_constructor
(ctxt : Name_resolution.context) (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 = (pos : Pos.t) : EnumName.t * EnumConstructor.t =
let path, constructor = let path, constructor =
match constructor with match constructor0 with
| [c] -> Mark.remove c | [c] -> Mark.remove c
| _ -> | _ ->
Message.raise_spanned_error pos Message.raise_spanned_error pos
@ -147,7 +147,7 @@ let disambiguate_constructor
in in
let possible_c_uids = let possible_c_uids =
try Ident.Map.find (Mark.remove constructor) ctxt.constructor_idmap 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 in
match path with match path with
| [] -> | [] ->
@ -160,19 +160,25 @@ let disambiguate_constructor
possible_c_uids; possible_c_uids;
EnumName.Map.choose possible_c_uids EnumName.Map.choose possible_c_uids
| [enum] -> ( | [enum] -> (
(* The path is fully qualified *)
let e_uid = Name_resolution.get_enum ctxt enum in
try try
(* The path is fully qualified *) let c_uid = EnumName.Map.find e_uid possible_c_uids in
let e_uid = Name_resolution.get_enum ctxt enum in e_uid, c_uid
try with EnumName.Map.Not_found _ ->
let c_uid = EnumName.Map.find e_uid possible_c_uids in Message.raise_spanned_error pos "Enum %s does not contain case %s"
e_uid, c_uid (Mark.remove enum) (Mark.remove constructor))
with Not_found -> | (modname, mpos) :: path -> (
Message.raise_spanned_error pos "Enum %s does not contain case %s" let modname = ModuleName.of_string modname in
(Mark.remove enum) (Mark.remove constructor) match ModuleName.Map.find_opt modname ctxt.modules with
with Not_found -> | None ->
Message.raise_spanned_error (Mark.get enum) Message.raise_spanned_error mpos "Module \"%a\" not found"
"Enum %s has not been defined before" (Mark.remove enum)) ModuleName.format modname
| _ -> Message.raise_spanned_error pos "Qualified paths are not supported yet" | 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 int100 = Runtime.integer_of_int 100
let rat100 = Runtime.decimal_of_integer int100 let rat100 = Runtime.decimal_of_integer int100
@ -204,19 +210,22 @@ let rec translate_expr
(scope : ScopeName.t option) (scope : ScopeName.t option)
(inside_definition_of : Ast.ScopeDef.t Mark.pos option) (inside_definition_of : Ast.ScopeDef.t Mark.pos option)
(ctxt : Name_resolution.context) (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 = let scope_vars =
match scope with match scope with
| None -> Ident.Map.empty | None -> Ident.Map.empty
| Some s -> (ScopeName.Map.find s ctxt.scopes).var_idmap | Some s -> (ScopeName.Map.find s ctxt.scopes).var_idmap
in 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 pos = Mark.get expr in
let emark = Untyped { pos } in let emark = Untyped { pos } in
match Mark.remove expr with match Mark.remove expr with
| Paren e -> rec_helper e | Paren e -> rec_helper e
| Binop | Binop
( (Surface.Ast.And, _pos_op), ( (S.And, _pos_op),
( TestMatchCase (e1_sub, ((constructors, Some binding), pos_pattern)), ( TestMatchCase (e1_sub, ((constructors, Some binding), pos_pattern)),
_pos_e1 ), _pos_e1 ),
e2 ) -> e2 ) ->
@ -234,16 +243,15 @@ let rec translate_expr
(Expr.elit (LBool false) emark) (Expr.elit (LBool false) emark)
[tau] pos [tau] pos
else else
let ctxt, binding_var = let binding_var = Var.make (Mark.remove binding) in
Name_resolution.add_def_local_var ctxt (Mark.remove binding) let local_vars =
Ident.Map.add (Mark.remove binding) binding_var local_vars
in 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) Expr.make_abs [| binding_var |] e2 [tau] pos)
(EnumName.Map.find enum_uid ctxt.enums) (EnumName.Map.find enum_uid ctxt.enums)
in in
Expr.ematch Expr.ematch ~e:(rec_helper e1_sub) ~name:enum_uid ~cases emark
(translate_expr scope inside_definition_of ctxt e1_sub)
enum_uid cases emark
| Binop ((((S.And | S.Or | S.Xor), _) as op), e1, e2) -> | Binop ((((S.And | S.Or | S.Xor), _) as op), e1, e2) ->
check_formula op e1; check_formula op e1;
check_formula op e2; check_formula op e2;
@ -311,7 +319,7 @@ let rec translate_expr
| Ident ([], (x, pos)) -> ( | Ident ([], (x, pos)) -> (
(* first we check whether this is a local var, then we resort to scope-wide (* first we check whether this is a local var, then we resort to scope-wide
variables, then global variables *) 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 -> | Some uid ->
Expr.make_var uid emark Expr.make_var uid emark
(* the whole box thing is to accomodate for this case *) (* the whole box thing is to accomodate for this case *)
@ -343,20 +351,21 @@ let rec translate_expr
else else
(* Tricky: we have to retrieve in the list the previous state (* Tricky: we have to retrieve in the list the previous state
with respect to the state that we are defining. *) with respect to the state that we are defining. *)
let correct_state = ref None in let rec find_prev_state = function
ignore | [] -> None
(List.fold_left | st0 :: st1 :: _ when StateName.equal inside_def_state st1
(fun previous_state state -> ->
if StateName.equal inside_def_state state then Some st0
correct_state := previous_state; | _ :: states -> find_prev_state states
Some state) in
None states); find_prev_state states)
!correct_state)
| _ -> | _ ->
(* we take the last state in the chain *) (* we take the last state in the chain *)
Some (List.hd (List.rev states))) Some (List.hd (List.rev states)))
in in
Expr.elocation (DesugaredScopeVar ((uid, pos), x_state)) emark Expr.elocation
(DesugaredScopeVar { name = uid, pos; state = x_state })
emark
| Some (SubScope _) | Some (SubScope _)
(* Note: allowing access to a global variable with the same name as a (* 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 *) 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 match Ident.Map.find_opt x ctxt.topdefs with
| Some v -> | Some v ->
Expr.elocation Expr.elocation
(ToplevelVar (v, Mark.get (TopdefName.get_info v))) (ToplevelVar { name = v, Mark.get (TopdefName.get_info v) })
emark emark
| None -> | None ->
Name_resolution.raise_unknown_identifier Name_resolution.raise_unknown_identifier
"for a local, scope-wide or global variable" (x, pos)))) "for a local, scope-wide or global variable" (x, pos))))
| Surface.Ast.Ident (path, x) -> | Ident (path, name) -> (
let path = List.map Mark.remove path in let ctxt = Name_resolution.module_ctx ctxt path in
Expr.eexternal (path, Mark.remove x) emark 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)) -> ( | Dotted (e, ((path, x), _ppos)) -> (
match path, Mark.remove e with match path, Mark.remove e with
| [], Ident ([], (y, _)) | [], Ident ([], (y, _))
@ -388,32 +403,39 @@ let rec translate_expr
in in
Expr.elocation Expr.elocation
(SubScopeVar (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 emark
| _ -> | _ ->
(* In this case e.x is the struct field x access of expression e *) (* 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 e = rec_helper e in
let str = let rec get_str ctxt = function
match path with
| [] -> None | [] -> None
| [c] -> ( | [c] -> Some (Name_resolution.get_struct ctxt c)
try Some (Name_resolution.get_struct ctxt c) | (modname, mpos) :: path -> (
with Not_found -> let modname = ModuleName.of_string modname in
Message.raise_spanned_error (Mark.get c) match ModuleName.Map.find_opt modname ctxt.modules with
"Structure %s was not declared" (Mark.remove c)) | None ->
| _ -> Message.raise_spanned_error mpos "Module \"%a\" not found"
Message.raise_spanned_error pos ModuleName.format modname
"Qualified paths are not supported yet" | Some ctxt -> get_str ctxt path)
in 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) -> | FunCall (f, args) ->
Expr.eapp (rec_helper f) (List.map rec_helper args) emark Expr.eapp (rec_helper f) (List.map rec_helper args) emark
| ScopeCall ((([], sc_name), _), fields) -> | ScopeCall (((path, id), _), fields) ->
if scope = None then if scope = None then
Message.raise_spanned_error pos Message.raise_spanned_error pos
"Scope calls are not allowed outside of a scope"; "Scope calls are not allowed outside of a scope";
let called_scope = Name_resolution.get_scope ctxt sc_name in let called_scope, scope_def =
let scope_def = ScopeName.Map.find called_scope ctxt.scopes in 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 = let in_struct =
List.fold_left List.fold_left
(fun acc (fld_id, e) -> (fun acc (fld_id, e) ->
@ -444,18 +466,13 @@ let rec translate_expr
acc) acc)
ScopeVar.Map.empty fields ScopeVar.Map.empty fields
in in
Expr.escopecall called_scope in_struct emark Expr.escopecall ~scope:called_scope ~args:in_struct emark
| ScopeCall (((_, _sc_name), _), _fields) ->
Message.raise_spanned_error pos "Qualified paths are not supported yet"
| LetIn (x, e1, e2) -> | 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 let tau = TAny, Mark.get x in
(* This type will be resolved in Scopelang.Desambiguation *) (* This type will be resolved in Scopelang.Desambiguation *)
let fn = let fn = Expr.make_abs [| v |] (rec_helper ~local_vars e2) [tau] pos in
Expr.make_abs [| v |]
(translate_expr scope inside_definition_of ctxt e2)
[tau] pos
in
Expr.eapp fn [rec_helper e1] emark Expr.eapp fn [rec_helper e1] emark
| StructLit ((([], s_name), _), fields) -> | StructLit ((([], s_name), _), fields) ->
let s_uid = let s_uid =
@ -473,7 +490,7 @@ let rec translate_expr
try try
StructName.Map.find s_uid StructName.Map.find s_uid
(Ident.Map.find (Mark.remove f_name) ctxt.field_idmap) (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) Message.raise_spanned_error (Mark.get f_name)
"This identifier should refer to a field of struct %s" "This identifier should refer to a field of struct %s"
(Mark.remove s_name) (Mark.remove s_name)
@ -484,7 +501,7 @@ let rec translate_expr
Message.raise_multispanned_error Message.raise_multispanned_error
[None, Mark.get f_e; None, Expr.pos e_field] [None, Mark.get f_e; None, Expr.pos e_field]
"The field %a has been defined twice:" StructField.format f_uid); "The field %a has been defined twice:" StructField.format f_uid);
let f_e = 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.add f_uid f_e s_fields)
StructField.Map.empty fields StructField.Map.empty fields
in in
@ -497,21 +514,21 @@ let rec translate_expr
StructField.format expected_f) StructField.format expected_f)
expected_s_fields; expected_s_fields;
Expr.estruct s_uid s_fields emark Expr.estruct ~name:s_uid ~fields:s_fields emark
| StructLit (((_, _s_name), _), _fields) -> | StructLit (((_, _s_name), _), _fields) ->
Message.raise_spanned_error pos "Qualified paths are not supported yet" Message.raise_spanned_error pos "Qualified paths are not supported yet"
| EnumInject (((path, (constructor, pos_constructor)), _), payload) -> ( | EnumInject (((path, (constructor, pos_constructor)), _), payload) -> (
let possible_c_uids = let get_possible_c_uids ctxt =
try Ident.Map.find constructor ctxt.constructor_idmap try Ident.Map.find constructor ctxt.Name_resolution.constructor_idmap
with Not_found -> with Ident.Map.Not_found _ ->
raise_error_cons_not_found ctxt (constructor, pos_constructor) raise_error_cons_not_found ctxt (constructor, pos_constructor)
in in
let mark_constructor = Untyped { pos = pos_constructor } in let mark_constructor = Untyped { pos = pos_constructor } in
match path with match path with
| [] -> | [] ->
let possible_c_uids = get_possible_c_uids ctxt in
if if
(* No constructor name was specified *) (* No enum name was specified *)
EnumName.Map.cardinal possible_c_uids > 1 EnumName.Map.cardinal possible_c_uids > 1
then then
Message.raise_spanned_error pos_constructor Message.raise_spanned_error pos_constructor
@ -522,43 +539,42 @@ let rec translate_expr
possible_c_uids possible_c_uids
else else
let e_uid, c_uid = EnumName.Map.choose possible_c_uids in let e_uid, c_uid = EnumName.Map.choose possible_c_uids in
let payload = let payload = Option.map rec_helper payload in
Option.map (translate_expr scope inside_definition_of ctxt) payload
in
Expr.einj Expr.einj
(match payload with ~e:
| 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
(match payload with (match payload with
| Some e' -> e' | Some e' -> e'
| None -> Expr.elit LUnit mark_constructor) | None -> Expr.elit LUnit mark_constructor)
c_uid e_uid emark ~cons:c_uid ~name:e_uid emark
with Not_found -> | path_enum -> (
Message.raise_spanned_error pos "Enum %s does not contain case %s" let path, enum =
(Mark.remove enum) constructor match List.rev path_enum with
with Not_found -> | enum :: rpath -> List.rev rpath, enum
Message.raise_spanned_error (Mark.get enum) | _ -> assert false
"Enum %s has not been defined before" (Mark.remove enum)) in
| _ -> let ctxt = Name_resolution.module_ctx ctxt path in
Message.raise_spanned_error pos "Qualified paths are not supported yet") 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)) -> | 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 = let cases_d, e_uid =
disambiguate_match_and_build_expression scope inside_definition_of ctxt disambiguate_match_and_build_expression scope inside_definition_of ctxt
cases local_vars cases
in in
Expr.ematch e1 e_uid cases_d emark Expr.ematch ~e:e1 ~name:e_uid ~cases:cases_d emark
| TestMatchCase (e1, pattern) -> | TestMatchCase (e1, pattern) ->
(match snd (Mark.remove pattern) with (match snd (Mark.remove pattern) with
| None -> () | None -> ()
@ -579,19 +595,16 @@ let rec translate_expr
[tau] pos) [tau] pos)
(EnumName.Map.find enum_uid ctxt.enums) (EnumName.Map.find enum_uid ctxt.enums)
in in
Expr.ematch Expr.ematch ~e:(rec_helper e1) ~name:enum_uid ~cases emark
(translate_expr scope inside_definition_of ctxt e1)
enum_uid cases emark
| ArrayLit es -> Expr.earray (List.map rec_helper es) emark | ArrayLit es -> Expr.earray (List.map rec_helper es) emark
| CollectionOp (((S.Filter { f } | S.Map { f }) as op), collection) -> | CollectionOp (((S.Filter { f } | S.Map { f }) as op), collection) ->
let collection = rec_helper collection in let collection = rec_helper collection in
let param, predicate = f in let param_name, predicate = f in
let ctxt, param = let param = Var.make (Mark.remove param_name) in
Name_resolution.add_def_local_var ctxt (Mark.remove param) let local_vars = Ident.Map.add (Mark.remove param_name) param local_vars in
in
let f_pred = let f_pred =
Expr.make_abs [| param |] Expr.make_abs [| param |]
(translate_expr scope inside_definition_of ctxt predicate) (rec_helper ~local_vars predicate)
[TAny, pos] [TAny, pos]
pos pos
in in
@ -605,18 +618,17 @@ let rec translate_expr
emark) emark)
[f_pred; collection] emark [f_pred; collection] emark
| CollectionOp | 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 default = rec_helper default in
let pos_dft = Expr.pos default in let pos_dft = Expr.pos default in
let collection = rec_helper collection in let collection = rec_helper collection in
let ctxt, param = let param = Var.make (Mark.remove param_name) in
Name_resolution.add_def_local_var ctxt (Mark.remove param) let local_vars = Ident.Map.add (Mark.remove param_name) param local_vars in
in
let cmp_op = if max then Op.Gt else Op.Lt in let cmp_op = if max then Op.Gt else Op.Lt in
let f_pred = let f_pred =
Expr.make_abs [| param |] Expr.make_abs [| param |]
(translate_expr scope inside_definition_of ctxt predicate) (rec_helper ~local_vars predicate)
[TAny, pos] [TAny, pos]
pos pos
in in
@ -655,16 +667,15 @@ let rec translate_expr
in in
let init = Expr.elit (LBool init) emark in let init = Expr.elit (LBool init) emark in
let param0, predicate = predicate in let param0, predicate = predicate in
let ctxt, param = let param = Var.make (Mark.remove param0) in
Name_resolution.add_def_local_var ctxt (Mark.remove param0) let local_vars = Ident.Map.add (Mark.remove param0) param local_vars in
in
let f = let f =
let acc_var = Var.make "acc" in let acc_var = Var.make "acc" in
let acc = Expr.make_var acc_var (Untyped { pos = Mark.get param0 }) in let acc = Expr.make_var acc_var (Untyped { pos = Mark.get param0 }) in
Expr.eabs Expr.eabs
(Expr.bind [| acc_var; param |] (Expr.bind [| acc_var; param |]
(Expr.eapp (translate_binop op pos) (Expr.eapp (translate_binop op pos)
[acc; translate_expr scope inside_definition_of ctxt predicate] [acc; rec_helper ~local_vars predicate]
emark)) emark))
[TAny, pos; TAny, pos] [TAny, pos; TAny, pos]
emark emark
@ -674,7 +685,7 @@ let rec translate_expr
[f; init; collection] emark [f; init; collection] emark
| CollectionOp (AggregateExtremum { max; default }, collection) -> | CollectionOp (AggregateExtremum { max; default }, collection) ->
let collection = rec_helper collection in 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 = translate_binop (if max then S.Gt KPoly else S.Lt KPoly) pos in
let op_f = let op_f =
(* fun x1 x2 -> if op x1 x2 then x1 else x2 *) (* 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_var = Var.make "acc" in
let acc = Expr.make_var acc_var emark in let acc = Expr.make_var acc_var emark in
let f_body = let f_body =
let member = translate_expr scope inside_definition_of ctxt member in let member = rec_helper member in
Expr.eapp Expr.eapp
(Expr.eop Or [TLit TBool, pos; TLit TBool, pos] emark) (Expr.eop Or [TLit TBool, pos; TLit TBool, pos] emark)
[ [
@ -763,13 +774,14 @@ and disambiguate_match_and_build_expression
(scope : ScopeName.t option) (scope : ScopeName.t option)
(inside_definition_of : Ast.ScopeDef.t Mark.pos option) (inside_definition_of : Ast.ScopeDef.t Mark.pos option)
(ctxt : Name_resolution.context) (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 = Ast.expr boxed EnumConstructor.Map.t * EnumName.t =
let create_var = function let create_var local_vars = function
| None -> ctxt, Var.make "_" | None -> local_vars, Var.make "_"
| Some param -> | Some param ->
let ctxt, param_var = Name_resolution.add_def_local_var ctxt param in let param_var = Var.make param in
ctxt, param_var Ident.Map.add param param_var local_vars, param_var
in in
let bind_case_body let bind_case_body
(c_uid : EnumConstructor.t) (c_uid : EnumConstructor.t)
@ -786,13 +798,11 @@ and disambiguate_match_and_build_expression
in in
let bind_match_cases (cases_d, e_uid, curr_index) (case, case_pos) = let bind_match_cases (cases_d, e_uid, curr_index) (case, case_pos) =
match case with match case with
| Surface.Ast.MatchCase case -> | S.MatchCase case ->
let constructor, binding = let constructor, binding = Mark.remove case.S.match_case_pattern in
Mark.remove case.Surface.Ast.match_case_pattern
in
let e_uid', c_uid = let e_uid', c_uid =
disambiguate_constructor ctxt constructor disambiguate_constructor ctxt constructor
(Mark.get case.Surface.Ast.match_case_pattern) (Mark.get case.S.match_case_pattern)
in in
let e_uid = let e_uid =
match e_uid with match e_uid with
@ -801,7 +811,7 @@ and disambiguate_match_and_build_expression
if e_uid = e_uid' then e_uid if e_uid = e_uid' then e_uid
else else
Message.raise_spanned_error 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 \ "This case matches a constructor of enumeration %a but previous \
case were matching constructors of enumeration %a" case were matching constructors of enumeration %a"
EnumName.format e_uid EnumName.format e_uid' EnumName.format e_uid EnumName.format e_uid'
@ -813,17 +823,19 @@ and disambiguate_match_and_build_expression
[None, Mark.get case.match_case_expr; None, Expr.pos e_case] [None, Mark.get case.match_case_expr; None, Expr.pos e_case]
"The constructor %a has been matched twice:" EnumConstructor.format "The constructor %a has been matched twice:" EnumConstructor.format
c_uid); c_uid);
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 = let case_body =
translate_expr scope inside_definition_of ctxt translate_expr scope inside_definition_of ctxt local_vars
case.Surface.Ast.match_case_expr case.S.match_case_expr
in in
let e_binder = Expr.bind [| param_var |] case_body 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 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, ( EnumConstructor.Map.add c_uid case_expr cases_d,
Some e_uid, Some e_uid,
curr_index + 1 ) curr_index + 1 )
| Surface.Ast.WildCard match_case_expr -> ( | S.WildCard match_case_expr -> (
let nb_cases = List.length cases in let nb_cases = List.length cases in
let raise_wildcard_not_last_case_err () = let raise_wildcard_not_last_case_err () =
Message.raise_multispanned_error Message.raise_multispanned_error
@ -867,9 +879,10 @@ and disambiguate_match_and_build_expression
... ...
| CaseN -> wildcard_payload *) | CaseN -> wildcard_payload *)
(* Creates the 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 = 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 in
let e_binder = Expr.bind [| payload_var |] case_body 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 let process_rule_parameters
ctxt ctxt
(def_key : Ast.ScopeDef.t Mark.pos) (def_key : Ast.ScopeDef.t Mark.pos)
(def : Surface.Ast.definition) : (def : S.definition) :
Name_resolution.context Ast.expr Var.t Ident.Map.t
* (Ast.expr Var.t Mark.pos * typ) list Mark.pos option = * (Ast.expr Var.t Mark.pos * typ) list Mark.pos option =
let decl_name, decl_pos = def_key in let decl_name, decl_pos = def_key in
let declared_params = Name_resolution.get_params ctxt decl_name in let declared_params = Name_resolution.get_params ctxt decl_name in
match declared_params, def.S.definition_parameter with match declared_params, def.S.definition_parameter with
| None, None -> ctxt, None | None, None -> Ident.Map.empty, None
| None, Some (_, pos) -> | None, Some (_, pos) ->
Message.raise_multispanned_error Message.raise_multispanned_error
[ [
@ -959,26 +972,27 @@ let process_rule_parameters
Message.raise_multispanned_error Message.raise_multispanned_error
[ [
Some "Arguments declared here", pos; Some "Arguments declared here", pos;
( Some "Definition missing the arguments", Some "Definition missing the arguments", Mark.get def.S.definition_name;
Mark.get def.Surface.Ast.definition_name );
] ]
"This definition for %a is missing the arguments" Ast.ScopeDef.format "This definition for %a is missing the arguments" Ast.ScopeDef.format
decl_name decl_name
| Some (pdecl, pos_decl), Some (pdefs, pos_def) -> | Some (pdecl, pos_decl), Some (pdefs, pos_def) ->
arglist_eq_check pos_decl pos_def (List.map fst pdecl) pdefs; arglist_eq_check pos_decl pos_def (List.map fst pdecl) pdefs;
let ctxt, params = let local_vars, params =
List.fold_left_map List.fold_left_map
(fun ctxt ((lbl, pos), ty) -> (fun local_vars ((lbl, pos), ty) ->
let ctxt, v = Name_resolution.add_def_local_var ctxt lbl in let v = Var.make lbl in
ctxt, ((v, pos), ty)) let local_vars = Ident.Map.add lbl v local_vars in
ctxt pdecl local_vars, ((v, pos), ty))
Ident.Map.empty pdecl
in in
ctxt, Some (params, pos_def) local_vars, Some (params, pos_def)
(** Translates a surface definition into condition into a desugared {!type: (** Translates a surface definition into condition into a desugared {!type:
Ast.rule} *) Ast.rule} *)
let process_default let process_default
(ctxt : Name_resolution.context) (ctxt : Name_resolution.context)
(local_vars : Ast.expr Var.t Ident.Map.t)
(scope : ScopeName.t) (scope : ScopeName.t)
(def_key : Ast.ScopeDef.t Mark.pos) (def_key : Ast.ScopeDef.t Mark.pos)
(rule_id : RuleName.t) (rule_id : RuleName.t)
@ -986,15 +1000,16 @@ let process_default
(precond : Ast.expr boxed option) (precond : Ast.expr boxed option)
(exception_situation : Ast.exception_situation) (exception_situation : Ast.exception_situation)
(label_situation : Ast.label_situation) (label_situation : Ast.label_situation)
(just : Surface.Ast.expression option) (just : S.expression option)
(cons : Surface.Ast.expression) : Ast.rule = (cons : S.expression) : Ast.rule =
let just = let just =
match just with 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 | None -> None
in in
let just = merge_conditions precond just (Mark.get def_key) 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; Ast.rule_just = just;
rule_cons = cons; rule_cons = cons;
@ -1011,7 +1026,7 @@ let process_def
(scope_uid : ScopeName.t) (scope_uid : ScopeName.t)
(ctxt : Name_resolution.context) (ctxt : Name_resolution.context)
(prgm : Ast.program) (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 : Ast.scope = ScopeName.Map.find scope_uid prgm.program_scopes in
let scope_ctxt = ScopeName.Map.find scope_uid ctxt.scopes in let scope_ctxt = ScopeName.Map.find scope_uid ctxt.scopes in
let def_key = let def_key =
@ -1024,7 +1039,7 @@ let process_def
Ast.ScopeDef.Map.find def_key scope_ctxt.scope_defs_contexts Ast.ScopeDef.Map.find def_key scope_ctxt.scope_defs_contexts
in in
(* We add to the name resolution context the name of the parameter variable *) (* 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 process_rule_parameters ctxt (Mark.copy def.definition_name def_key) def
in in
let scope_updated = let scope_updated =
@ -1038,7 +1053,7 @@ let process_def
| None -> Ast.Unlabeled | None -> Ast.Unlabeled
in in
let exception_situation = let exception_situation =
match def.Surface.Ast.definition_exception_to with match def.S.definition_exception_to with
| NotAnException -> Ast.BaseCase | NotAnException -> Ast.BaseCase
| UnlabeledException -> ( | UnlabeledException -> (
match scope_def_ctxt.default_exception_rulename with 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 Ident.Map.find (Mark.remove label_str) scope_def_ctxt.label_idmap
in in
ExceptionToLabel (label_id, Mark.get label_str) ExceptionToLabel (label_id, Mark.get label_str)
with Not_found -> with Ident.Map.Not_found _ ->
Message.raise_spanned_error (Mark.get label_str) Message.raise_spanned_error (Mark.get label_str)
"Unknown label for the scope variable %a: \"%s\"" "Unknown label for the scope variable %a: \"%s\""
Ast.ScopeDef.format def_key (Mark.remove label_str)) Ast.ScopeDef.format def_key (Mark.remove label_str))
@ -1064,7 +1079,7 @@ let process_def
scope_def with scope_def with
scope_def_rules = scope_def_rules =
RuleName.Map.add rule_name 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) (def_key, Mark.get def.definition_name)
rule_name param_uids precond exception_situation label_situation rule_name param_uids precond exception_situation label_situation
def.definition_condition def.definition_expr) def.definition_condition def.definition_expr)
@ -1082,14 +1097,14 @@ let process_def
ScopeName.Map.add scope_uid scope_updated prgm.program_scopes; 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 let process_rule
(precond : Ast.expr boxed option) (precond : Ast.expr boxed option)
(scope : ScopeName.t) (scope : ScopeName.t)
(ctxt : Name_resolution.context) (ctxt : Name_resolution.context)
(prgm : Ast.program) (prgm : Ast.program)
(rule : Surface.Ast.rule) : Ast.program = (rule : S.rule) : Ast.program =
let def = Surface.Ast.rule_to_def rule in let def = S.rule_to_def rule in
process_def precond scope ctxt prgm def process_def precond scope ctxt prgm def
(** Translates assertions *) (** Translates assertions *)
@ -1098,17 +1113,17 @@ let process_assert
(scope_uid : ScopeName.t) (scope_uid : ScopeName.t)
(ctxt : Name_resolution.context) (ctxt : Name_resolution.context)
(prgm : Ast.program) (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 scope : Ast.scope = ScopeName.Map.find scope_uid prgm.program_scopes in
let ass = let ass =
translate_expr (Some scope_uid) None ctxt translate_expr (Some scope_uid) None ctxt Ident.Map.empty
(match ass.Surface.Ast.assertion_condition with (match ass.S.assertion_condition with
| None -> ass.Surface.Ast.assertion_content | None -> ass.S.assertion_content
| Some cond -> | Some cond ->
( Surface.Ast.IfThenElse ( S.IfThenElse
( cond, ( cond,
ass.Surface.Ast.assertion_content, ass.S.assertion_content,
Mark.copy cond (Surface.Ast.Literal (Surface.Ast.LBool true)) ), Mark.copy cond (S.Literal (S.LBool true)) ),
Mark.get cond )) Mark.get cond ))
in in
let assertion = let assertion =
@ -1138,23 +1153,25 @@ let process_assert
(** Translates a surface definition, rule or assertion *) (** Translates a surface definition, rule or assertion *)
let process_scope_use_item let process_scope_use_item
(precond : Surface.Ast.expression option) (precond : S.expression option)
(scope : ScopeName.t) (scope : ScopeName.t)
(ctxt : Name_resolution.context) (ctxt : Name_resolution.context)
(prgm : Ast.program) (prgm : Ast.program)
(item : Surface.Ast.scope_use_item Mark.pos) : Ast.program = (item : S.scope_use_item Mark.pos) : Ast.program =
let precond = Option.map (translate_expr (Some scope) None ctxt) precond in let precond =
Option.map (translate_expr (Some scope) None ctxt Ident.Map.empty) precond
in
match Mark.remove item with match Mark.remove item with
| Surface.Ast.Rule rule -> process_rule precond scope ctxt prgm rule | S.Rule rule -> process_rule precond scope ctxt prgm rule
| Surface.Ast.Definition def -> process_def precond scope ctxt prgm def | S.Definition def -> process_def precond scope ctxt prgm def
| Surface.Ast.Assertion ass -> process_assert precond scope ctxt prgm ass | S.Assertion ass -> process_assert precond scope ctxt prgm ass
| Surface.Ast.DateRounding (r, _) -> | S.DateRounding (r, _) ->
let scope_uid = scope in let scope_uid = scope in
let scope : Ast.scope = ScopeName.Map.find scope_uid prgm.program_scopes in let scope : Ast.scope = ScopeName.Map.find scope_uid prgm.program_scopes in
let r = let r =
match r with match r with
| Surface.Ast.Increasing -> Ast.Increasing | S.Increasing -> Ast.Increasing
| Surface.Ast.Decreasing -> Ast.Decreasing | S.Decreasing -> Ast.Decreasing
in in
let new_scope = let new_scope =
match match
@ -1188,18 +1205,18 @@ let process_scope_use_item
let check_unlabeled_exception let check_unlabeled_exception
(scope : ScopeName.t) (scope : ScopeName.t)
(ctxt : Name_resolution.context) (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 let scope_ctxt = ScopeName.Map.find scope ctxt.scopes in
match Mark.remove item with match Mark.remove item with
| Surface.Ast.Rule _ | Surface.Ast.Definition _ -> ( | S.Rule _ | S.Definition _ -> (
let def_key, exception_to = let def_key, exception_to =
match Mark.remove item with match Mark.remove item with
| Surface.Ast.Rule rule -> | S.Rule rule ->
( Name_resolution.get_def_key ( Name_resolution.get_def_key
(Mark.remove rule.rule_name) (Mark.remove rule.rule_name)
rule.rule_state scope ctxt (Mark.get rule.rule_name), rule.rule_state scope ctxt (Mark.get rule.rule_name),
rule.rule_exception_to ) rule.rule_exception_to )
| Surface.Ast.Definition def -> | S.Definition def ->
( Name_resolution.get_def_key ( Name_resolution.get_def_key
(Mark.remove def.definition_name) (Mark.remove def.definition_name)
def.definition_state scope ctxt def.definition_state scope ctxt
@ -1212,10 +1229,10 @@ let check_unlabeled_exception
Ast.ScopeDef.Map.find def_key scope_ctxt.scope_defs_contexts Ast.ScopeDef.Map.find def_key scope_ctxt.scope_defs_contexts
in in
match exception_to with 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 (* If this is an unlabeled exception, we check that it has a unique default
definition *) definition *)
| Surface.Ast.UnlabeledException -> ( | S.UnlabeledException -> (
match scope_def_ctxt.default_exception_rulename with match scope_def_ctxt.default_exception_rulename with
| None -> | None ->
Message.raise_spanned_error (Mark.get item) Message.raise_spanned_error (Mark.get item)
@ -1233,7 +1250,7 @@ let check_unlabeled_exception
let process_scope_use let process_scope_use
(ctxt : Name_resolution.context) (ctxt : Name_resolution.context)
(prgm : Ast.program) (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 let scope_uid = Name_resolution.get_scope ctxt use.scope_use_name in
(* Make sure the scope exists *) (* Make sure the scope exists *)
let prgm = let prgm =
@ -1261,16 +1278,18 @@ let process_topdef
let expr_opt = let expr_opt =
match def.S.topdef_expr, def.S.topdef_args with match def.S.topdef_expr, def.S.topdef_args with
| None, _ -> None | 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, _) -> | Some e, Some (args, _) ->
let ctxt, args_tys = let local_vars, args_tys =
List.fold_left_map List.fold_left_map
(fun ctxt ((lbl, pos), ty) -> (fun local_vars ((lbl, pos), ty) ->
let ctxt, v = Name_resolution.add_def_local_var ctxt lbl in let v = Var.make lbl in
ctxt, ((v, pos), ty)) let local_vars = Ident.Map.add lbl v local_vars in
ctxt args local_vars, ((v, pos), ty))
Ident.Map.empty args
in 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 args, tys = List.split args_tys in
let e = let e =
Expr.make_abs Expr.make_abs
@ -1303,16 +1322,16 @@ let process_topdef
in in
{ prgm with Ast.program_topdefs } { 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_output = attr.scope_decl_context_io_output;
Ast.io_input = Ast.io_input =
Mark.map Mark.map
(fun io -> (fun io ->
match io with match io with
| Surface.Ast.Input -> Runtime.OnlyInput | S.Input -> Runtime.OnlyInput
| Surface.Ast.Internal -> Runtime.NoInput | S.Internal -> Runtime.NoInput
| Surface.Ast.Context -> Runtime.Reentrant) | S.Context -> Runtime.Reentrant)
attr.scope_decl_context_io_input; attr.scope_decl_context_io_input;
} }
@ -1371,8 +1390,12 @@ let init_scope_defs
in in
scope_def) scope_def)
| Name_resolution.SubScope (v0, subscope_uid) -> | Name_resolution.SubScope (v0, subscope_uid) ->
let sub_scope_def = let sub_scope_def = Name_resolution.get_scope_context ctxt subscope_uid in
ScopeName.Map.find subscope_uid ctxt.Name_resolution.scopes let ctxt =
List.fold_left
(fun ctx m -> ModuleName.Map.find m ctx.Name_resolution.modules)
ctxt
(ScopeName.path subscope_uid)
in in
Ident.Map.fold Ident.Map.fold
(fun _ v scope_def_map -> (fun _ v scope_def_map ->
@ -1399,11 +1422,10 @@ let init_scope_defs
Ident.Map.fold add_def scope_idmap Ast.ScopeDef.Map.empty Ident.Map.fold add_def scope_idmap Ast.ScopeDef.Map.empty
(** Main function of this module *) (** Main function of this module *)
let translate_program let translate_program (ctxt : Name_resolution.context) (surface : S.program) :
(ctxt : Name_resolution.context) Ast.program =
(prgm : Surface.Ast.program) : Ast.program = let desugared =
let empty_prgm = let get_program_scopes ctxt =
let program_scopes =
ScopeName.Map.mapi ScopeName.Map.mapi
(fun s_uid s_context -> (fun s_uid s_context ->
let scope_vars = let scope_vars =
@ -1412,8 +1434,10 @@ let translate_program
match v with match v with
| Name_resolution.SubScope _ -> acc | Name_resolution.SubScope _ -> acc
| Name_resolution.ScopeVar v -> ( | Name_resolution.ScopeVar v -> (
let v_sig = ScopeVar.Map.find v ctxt.var_typs in let v_sig =
match v_sig.var_sig_states_list with 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 | [] -> ScopeVar.Map.add v Ast.WholeVar acc
| states -> ScopeVar.Map.add v (Ast.States states) acc)) | states -> ScopeVar.Map.add v (Ast.States states) acc))
s_context.Name_resolution.var_idmap ScopeVar.Map.empty s_context.Name_resolution.var_idmap ScopeVar.Map.empty
@ -1438,57 +1462,80 @@ let translate_program
}) })
ctxt.Name_resolution.scopes ctxt.Name_resolution.scopes
in in
let translate_type t = Name_resolution.process_type ctxt t in let rec make_ctx ctxt =
{ let submodules =
Ast.program_ctx = ModuleName.Map.map make_ctx ctxt.Name_resolution.modules
{ in
ctx_structs = ctxt.Name_resolution.structs; {
ctx_enums = ctxt.Name_resolution.enums; Ast.program_ctx =
ctx_scopes = {
Ident.Map.fold (* After name resolution, type definitions (structs and enums) are
(fun _ def acc -> exposed at toplevel for easier lookup *)
match def with ctx_structs =
| Name_resolution.TScope (scope, scope_out_struct) -> ModuleName.Map.fold
ScopeName.Map.add scope scope_out_struct acc (fun _ prg acc ->
| _ -> acc) StructName.Map.union
ctxt.Name_resolution.typedefs ScopeName.Map.empty; (fun _ _ _ -> assert false)
ctx_struct_fields = ctxt.Name_resolution.field_idmap; acc prg.Ast.program_ctx.ctx_structs)
ctx_modules = submodules ctxt.Name_resolution.structs;
List.fold_left ctx_enums =
(fun map (path, def) -> ModuleName.Map.fold
match def with (fun _ prg acc ->
| Surface.Ast.Topdef { topdef_name; topdef_type; _ }, _pos -> EnumName.Map.union
Qident.Map.add (fun _ _ _ -> assert false)
(path, Mark.remove topdef_name) acc prg.Ast.program_ctx.ctx_enums)
(translate_type topdef_type) submodules ctxt.Name_resolution.enums;
map ctx_scopes =
| (ScopeDecl _ | StructDecl _ | EnumDecl _), _ (* as e *) -> Ident.Map.fold
map (* assert false (\* TODO *\) *) (fun _ def acc ->
| ScopeUse _, _ -> assert false) match def with
Qident.Map.empty prgm.Surface.Ast.program_interfaces; | Name_resolution.TScope (scope, scope_info) ->
}; ScopeName.Map.add scope scope_info acc
Ast.program_topdefs = TopdefName.Map.empty; | _ -> acc)
Ast.program_scopes; 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 in
let rec processer_structure let process_code_block ctxt prgm block =
(prgm : Ast.program) List.fold_left
(item : Surface.Ast.law_structure) : Ast.program = (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 match item with
| LawHeading (_, children) -> | S.LawHeading (_, children) ->
List.fold_left List.fold_left
(fun prgm child -> processer_structure prgm child) (fun prgm child -> process_structure prgm child)
prgm children prgm children
| CodeBlock (block, _, _) -> | S.CodeBlock (block, _, _) -> process_code_block ctxt prgm block
List.fold_left | S.LawInclude _ | S.LawText _ -> prgm
(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
in 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 in
StructName.Map.iter StructName.Map.iter
(fun s_name fields -> (fun s_name fields ->
if if StructName.path s_name <> [] then ()
else if
(not (StructField.Map.is_empty fields)) (not (StructField.Map.is_empty fields))
&& StructField.Map.for_all && StructField.Map.for_all
(fun field _ -> (fun field _ ->
@ -191,7 +192,8 @@ let detect_unused_enum_constructors (p : program) : unit =
in in
EnumName.Map.iter EnumName.Map.iter
(fun e_name constructors -> (fun e_name constructors ->
if if EnumName.path e_name <> [] then ()
else if
EnumConstructor.Map.for_all EnumConstructor.Map.for_all
(fun cons _ -> (fun cons _ ->
not (EnumConstructor.Set.mem cons enum_constructors_used)) 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 = type typedef =
| TStruct of StructName.t | TStruct of StructName.t
| TEnum of EnumName.t | TEnum of EnumName.t
| TScope of ScopeName.t * scope_out_struct | TScope of ScopeName.t * scope_info (** Implicitly defined output struct *)
(** Implicitly defined output struct *)
type context = { type context = {
local_var_idmap : Ast.expr Var.t Ident.Map.t; path : Uid.Path.t;
(** Inside a definition, local variables can be introduced by functions
arguments or pattern matching *)
typedefs : typedef Ident.Map.t; typedefs : typedef Ident.Map.t;
(** Gathers the names of the scopes, structs and enums *) (** Gathers the names of the scopes, structs and enums *)
field_idmap : StructField.t StructName.Map.t Ident.Map.t; field_idmap : StructField.t StructName.Map.t Ident.Map.t;
@ -82,11 +79,13 @@ type context = {
between different enums *) between different enums *)
scopes : scope_context ScopeName.Map.t; (** For each scope, its context *) scopes : scope_context ScopeName.Map.t; (** For each scope, its context *)
topdefs : TopdefName.t Ident.Map.t; (** Global definitions *) topdefs : TopdefName.t Ident.Map.t; (** Global definitions *)
topdef_types : typ TopdefName.Map.t;
structs : struct_context StructName.Map.t; structs : struct_context StructName.Map.t;
(** For each struct, its context *) (** For each struct, its context *)
enums : enum_context EnumName.Map.t; (** For each enum, its context *) enums : enum_context EnumName.Map.t; (** For each enum, its context *)
var_typs : var_sig ScopeVar.Map.t; var_typs : var_sig ScopeVar.Map.t;
(** The signatures of each scope variable declared *) (** The signatures of each scope variable declared *)
modules : context ModuleName.Map.t;
} }
(** Main context used throughout {!module: Surface.Desugaring} *) (** 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 = Surface.Ast.scope_decl_context_io =
(ScopeVar.Map.find uid ctxt.var_typs).var_sig_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 *) (** Get the variable uid inside the scope given in argument *)
let get_var_uid let get_var_uid
(scope_uid : ScopeName.t) (scope_uid : ScopeName.t)
(ctxt : context) (ctxt : context)
((x, pos) : Ident.t Mark.pos) : ScopeVar.t = ((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 match Ident.Map.find_opt x scope.var_idmap with
| Some (ScopeVar uid) -> uid | Some (ScopeVar uid) -> uid
| _ -> | _ ->
@ -132,7 +144,7 @@ let get_subscope_uid
(scope_uid : ScopeName.t) (scope_uid : ScopeName.t)
(ctxt : context) (ctxt : context)
((y, pos) : Ident.t Mark.pos) : SubScopeName.t = ((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 match Ident.Map.find_opt y scope.var_idmap with
| Some (SubScope (sub_uid, _sub_id)) -> sub_uid | Some (SubScope (sub_uid, _sub_id)) -> sub_uid
| _ -> raise_unknown_identifier "for a subscope of this scope" (y, pos) | _ -> raise_unknown_identifier "for a subscope of this scope" (y, pos)
@ -141,7 +153,7 @@ let get_subscope_uid
subscopes of [scope_uid]. *) subscopes of [scope_uid]. *)
let is_subscope_uid (scope_uid : ScopeName.t) (ctxt : context) (y : Ident.t) : let is_subscope_uid (scope_uid : ScopeName.t) (ctxt : context) (y : Ident.t) :
bool = 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 match Ident.Map.find_opt y scope.var_idmap with
| Some (SubScope _) -> true | Some (SubScope _) -> true
| _ -> false | _ -> 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 *) (** Checks if the var_uid belongs to the scope scope_uid *)
let belongs_to (ctxt : context) (uid : ScopeVar.t) (scope_uid : ScopeName.t) : let belongs_to (ctxt : context) (uid : ScopeVar.t) (scope_uid : ScopeName.t) :
bool = bool =
let scope = ScopeName.Map.find scope_uid ctxt.scopes in let scope = get_scope_context ctxt scope_uid in
Ident.Map.exists Ident.Map.exists
(fun _ -> function (fun _ -> function
| ScopeVar var_uid -> ScopeVar.equal uid var_uid | 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); Some "Scope defined at", Mark.get (ScopeName.get_info sid);
] ]
"Expecting an enum, but found a scope" "Expecting an enum, but found a scope"
| exception Not_found -> | exception Ident.Map.Not_found _ ->
Message.raise_spanned_error (Mark.get id) "No enum named %s found" Message.raise_spanned_error (Mark.get id) "No enum named %s found"
(Mark.remove id) (Mark.remove id)
@ -213,8 +225,8 @@ let get_struct ctxt id =
None, Mark.get id; None, Mark.get id;
Some "Enum defined at", Mark.get (EnumName.get_info eid); Some "Enum defined at", Mark.get (EnumName.get_info eid);
] ]
"Expecting an struct, but found an enum" "Expecting a struct, but found an enum"
| exception Not_found -> | exception Ident.Map.Not_found _ ->
Message.raise_spanned_error (Mark.get id) "No struct named %s found" Message.raise_spanned_error (Mark.get id) "No struct named %s found"
(Mark.remove id) (Mark.remove id)
@ -235,10 +247,21 @@ let get_scope ctxt id =
Some "Structure defined at", Mark.get (StructName.get_info sid); Some "Structure defined at", Mark.get (StructName.get_info sid);
] ]
"Expecting an scope, but found a structure" "Expecting an scope, but found a structure"
| exception Not_found -> | exception Ident.Map.Not_found _ ->
Message.raise_spanned_error (Mark.get id) "No scope named %s found" Message.raise_spanned_error (Mark.get id) "No scope named %s found"
(Mark.remove id) (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} *) (** {1 Declarations pass} *)
(** Process a subscope declaration *) (** Process a subscope declaration *)
@ -247,9 +270,9 @@ let process_subscope_decl
(ctxt : context) (ctxt : context)
(decl : Surface.Ast.scope_decl_context_scope) : context = (decl : Surface.Ast.scope_decl_context_scope) : context =
let name, name_pos = decl.scope_decl_context_scope_name in let name, name_pos = decl.scope_decl_context_scope_name in
let subscope, s_pos = decl.scope_decl_context_scope_sub_scope in let (path, subscope), s_pos = decl.scope_decl_context_scope_sub_scope 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 subscope scope_ctxt.var_idmap with match Ident.Map.find_opt (Mark.remove subscope) scope_ctxt.var_idmap with
| Some use -> | Some use ->
let info = let info =
match use with match use with
@ -258,11 +281,12 @@ let process_subscope_decl
in in
Message.raise_multispanned_error Message.raise_multispanned_error
[Some "first use", Mark.get info; Some "second use", s_pos] [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 -> | None ->
let sub_scope_uid = SubScopeName.fresh (name, name_pos) in let sub_scope_uid = SubScopeName.fresh (name, name_pos) in
let original_subscope_uid = 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 in
let scope_ctxt = let scope_ctxt =
{ {
@ -314,9 +338,16 @@ let rec process_base_typ
"Unknown type @{<yellow>\"%s\"@}, not a struct or enum previously \ "Unknown type @{<yellow>\"%s\"@}, not a struct or enum previously \
declared" declared"
ident) ident)
| Surface.Ast.Named (_path, (_ident, _pos)) -> | Surface.Ast.Named ((modul, mpos) :: path, id) -> (
Message.raise_spanned_error typ_pos let modul = ModuleName.of_string modul in
"Qualified paths are not supported yet") 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) *) (** Process a type (function or not) *)
let process_type (ctxt : context) ((naked_typ, typ_pos) : Surface.Ast.typ) : typ 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 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 is_cond = is_type_cond decl.scope_decl_context_item_typ in
let name, pos = decl.scope_decl_context_item_name 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 match Ident.Map.find_opt name scope_ctxt.var_idmap with
| Some use -> | Some use ->
let info = let info =
@ -405,18 +436,6 @@ let process_data_decl
ctxt.var_typs; 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 *) (** Process a struct declaration *)
let process_struct_decl (ctxt : context) (sdecl : Surface.Ast.struct_decl) : let process_struct_decl (ctxt : context) (sdecl : Surface.Ast.struct_decl) :
context = context =
@ -505,6 +524,18 @@ let process_enum_decl (ctxt : context) (edecl : Surface.Ast.enum_decl) : context
}) })
ctxt edecl.enum_decl_cases 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 *) (** Process an item declaration *)
let process_item_decl let process_item_decl
(scope : ScopeName.t) (scope : ScopeName.t)
@ -565,7 +596,7 @@ let process_scope_decl (ctxt : context) (decl : Surface.Ast.scope_decl) :
} }
in in
let out_struct_fields = 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 let str = get_struct ctxt decl.scope_decl_name in
Ident.Map.fold Ident.Map.fold
(fun id var svmap -> (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) StructName.Map.find str (Ident.Map.find id ctxt.field_idmap)
in in
ScopeVar.Map.add v field svmap 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 sco.var_idmap ScopeVar.Map.empty
in in
let typedefs = let typedefs =
Ident.Map.update Ident.Map.update
(Mark.remove decl.scope_decl_name) (Mark.remove decl.scope_decl_name)
(function (function
| Some (TScope (scope, { out_struct_name; _ })) -> | Some (TScope (scope, { in_struct_name; out_struct_name; _ })) ->
Some (TScope (scope, { out_struct_name; out_struct_fields })) Some
(TScope
(scope, { in_struct_name; out_struct_name; out_struct_fields }))
| _ -> assert false) | _ -> assert false)
ctxt.typedefs ctxt.typedefs
in in
@ -616,8 +649,9 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
(fun use -> (fun use ->
raise_already_defined_error (typedef_info use) name pos "scope") raise_already_defined_error (typedef_info use) name pos "scope")
(Ident.Map.find_opt name ctxt.typedefs); (Ident.Map.find_opt name ctxt.typedefs);
let scope_uid = ScopeName.fresh (name, pos) in let scope_uid = ScopeName.fresh ctxt.path (name, pos) in
let out_struct_uid = StructName.fresh (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 ctxt with
typedefs = typedefs =
@ -625,7 +659,8 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
(TScope (TScope
( scope_uid, ( scope_uid,
{ {
out_struct_name = out_struct_uid; in_struct_name;
out_struct_name;
out_struct_fields = ScopeVar.Map.empty; out_struct_fields = ScopeVar.Map.empty;
} )) } ))
ctxt.typedefs; ctxt.typedefs;
@ -644,7 +679,7 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
(fun use -> (fun use ->
raise_already_defined_error (typedef_info use) name pos "struct") raise_already_defined_error (typedef_info use) name pos "struct")
(Ident.Map.find_opt name ctxt.typedefs); (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 ctxt with
typedefs = typedefs =
@ -658,7 +693,7 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
(fun use -> (fun use ->
raise_already_defined_error (typedef_info use) name pos "enum") raise_already_defined_error (typedef_info use) name pos "enum")
(Ident.Map.find_opt name ctxt.typedefs); (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 ctxt with
typedefs = 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 raise_already_defined_error (TopdefName.get_info use) name pos
"toplevel definition") "toplevel definition")
(Ident.Map.find_opt name ctxt.topdefs); (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 } { ctxt with topdefs = Ident.Map.add name uid ctxt.topdefs }
(** Process a code item that is a declaration *) (** 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 | StructDecl sdecl -> process_struct_decl ctxt sdecl
| EnumDecl edecl -> process_enum_decl ctxt edecl | EnumDecl edecl -> process_enum_decl ctxt edecl
| ScopeUse _ -> ctxt | ScopeUse _ -> ctxt
| Topdef _ -> ctxt | Topdef def -> process_topdef ctxt def
(** Process a code block *) (** Process a code block *)
let process_code_block let process_code_block
(process_item : context -> Surface.Ast.code_item Mark.pos -> context)
(ctxt : context) (ctxt : context)
(block : Surface.Ast.code_block) (block : Surface.Ast.code_block) : context =
(process_item : context -> Surface.Ast.code_item Mark.pos -> context) :
context =
List.fold_left (fun ctxt decl -> process_item ctxt decl) ctxt block List.fold_left (fun ctxt decl -> process_item ctxt decl) ctxt block
(** Process a law structure, only considering the code blocks *) (** Process a law structure, only considering the code blocks *)
let rec process_law_structure let rec process_law_structure
(process_item : context -> Surface.Ast.code_item Mark.pos -> context)
(ctxt : context) (ctxt : context)
(s : Surface.Ast.law_structure) (s : Surface.Ast.law_structure) : context =
(process_item : context -> Surface.Ast.code_item Mark.pos -> context) :
context =
match s with match s with
| Surface.Ast.LawHeading (_, children) -> | Surface.Ast.LawHeading (_, children) ->
List.fold_left 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 ctxt children
| Surface.Ast.CodeBlock (block, _, _) -> | 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 | Surface.Ast.LawInclude _ | Surface.Ast.LawText _ -> ctxt
(** {1 Scope uses pass} *) (** {1 Scope uses pass} *)
@ -730,7 +763,7 @@ let get_def_key
try try
Some Some
(Ident.Map.find (Mark.remove state) var_sig.var_sig_states_idmap) (Ident.Map.find (Mark.remove state) var_sig.var_sig_states_idmap)
with Not_found -> with Ident.Map.Not_found _ ->
Message.raise_multispanned_error Message.raise_multispanned_error
[ [
None, Mark.get state; None, Mark.get state;
@ -906,34 +939,62 @@ let process_use_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
(** {1 API} *) (** {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 *) (** Derive the context from metadata, in one pass over the declarations *)
let form_context (prgm : Surface.Ast.program) : context = let form_context (prgm : Surface.Ast.program) : context =
let empty_ctxt = let modules =
{ List.fold_left import_module ModuleName.Map.empty prgm.program_modules
local_var_idmap = Ident.Map.empty; in
typedefs = Ident.Map.empty; let ctxt = { empty_ctxt with modules } in
scopes = ScopeName.Map.empty; let rec gather_var_sigs acc modules =
topdefs = Ident.Map.empty; (* Scope vars from imported modules need to be accessible directly for
var_typs = ScopeVar.Map.empty; definitions through submodules *)
structs = StructName.Map.empty; ModuleName.Map.fold
field_idmap = Ident.Map.empty; (fun _modname mctx acc ->
enums = EnumName.Map.empty; let acc = gather_var_sigs acc mctx.modules in
constructor_idmap = Ident.Map.empty; 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 in
let ctxt = let ctxt =
List.fold_left List.fold_left
(fun ctxt item -> process_law_structure ctxt item process_name_item) (process_law_structure 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)
ctxt prgm.program_items ctxt prgm.program_items
in in
let ctxt = let ctxt =
List.fold_left 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 ctxt prgm.program_items
in in
ctxt ctxt

22
compiler/desugared/name_resolution.mli
View File

@ -65,13 +65,11 @@ type var_sig = {
type typedef = type typedef =
| TStruct of StructName.t | TStruct of StructName.t
| TEnum of EnumName.t | TEnum of EnumName.t
| TScope of ScopeName.t * scope_out_struct | TScope of ScopeName.t * scope_info (** Implicitly defined output struct *)
(** Implicitly defined output struct *)
type context = { type context = {
local_var_idmap : Ast.expr Var.t Ident.Map.t; path : ModuleName.t list;
(** Inside a definition, local variables can be introduced by functions (** The current path being processed. Used for generating the Uids. *)
arguments or pattern matching *)
typedefs : typedef Ident.Map.t; typedefs : typedef Ident.Map.t;
(** Gathers the names of the scopes, structs and enums *) (** Gathers the names of the scopes, structs and enums *)
field_idmap : StructField.t StructName.Map.t Ident.Map.t; field_idmap : StructField.t StructName.Map.t Ident.Map.t;
@ -82,11 +80,14 @@ type context = {
between different enums *) between different enums *)
scopes : scope_context ScopeName.Map.t; (** For each scope, its context *) scopes : scope_context ScopeName.Map.t; (** For each scope, its context *)
topdefs : TopdefName.t Ident.Map.t; (** Global definitions *) 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; structs : struct_context StructName.Map.t;
(** For each struct, its context *) (** For each struct, its context *)
enums : enum_context EnumName.Map.t; (** For each enum, its context *) enums : enum_context EnumName.Map.t; (** For each enum, its context *)
var_typs : var_sig ScopeVar.Map.t; var_typs : var_sig ScopeVar.Map.t;
(** The signatures of each scope variable declared *) (** The signatures of each scope variable declared *)
modules : context ModuleName.Map.t;
} }
(** Main context used throughout {!module: Desugared.From_surface} *) (** 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 is_var_cond : context -> ScopeVar.t -> bool
val get_var_io : context -> ScopeVar.t -> Surface.Ast.scope_decl_context_io 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 val get_var_uid : ScopeName.t -> context -> Ident.t Mark.pos -> ScopeVar.t
(** Get the variable uid inside the scope given in argument *) (** 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_def_cond : context -> Ast.ScopeDef.t -> bool
val is_type_cond : Surface.Ast.typ -> 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 : val get_def_key :
Surface.Ast.scope_var -> Surface.Ast.scope_var ->
Surface.Ast.lident Mark.pos option -> 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 (** Find a scope definition from the typedefs, failing if there is none or it
has a different kind *) 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 val process_type : context -> Surface.Ast.typ -> typ
(** Convert a surface base type to an AST type *) (** 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" @{<yellow>%s@}, and @{<bold>--language@} was not specified"
filename) filename)
let load_module_interfaces prg options link_modules = let load_module_interfaces options link_modules =
List.fold_left List.map
(fun prg f -> (fun f ->
let lang = get_lang options (FileName f) in let lang = get_lang options (FileName f) in
let modname = modname_of_file f in let modname = modname_of_file f in
Surface.Parser_driver.add_interface (FileName f) lang [modname] prg) let intf = Surface.Parser_driver.load_interface (FileName f) lang in
prg link_modules modname, intf)
link_modules
module Passes = struct module Passes = struct
(* Each pass takes only its cli options, then calls upon its dependent passes (* Each pass takes only its cli options, then calls upon its dependent passes
(forwarding their options as needed) *) (forwarding their options as needed) *)
let surface options : Surface.Ast.program * Cli.backend_lang = let surface options ~link_modules : Surface.Ast.program * Cli.backend_lang =
Message.emit_debug "Reading files..."; Message.emit_debug "- SURFACE -";
let language = get_lang options options.input_file in let language = get_lang options options.input_file in
let prg = let prg =
Surface.Parser_driver.parse_top_level_file options.input_file language Surface.Parser_driver.parse_top_level_file options.input_file language
in 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 : let desugared options ~link_modules :
Desugared.Ast.program * Desugared.Name_resolution.context = Desugared.Ast.program * Desugared.Name_resolution.context =
let prg, _ = surface options in let prg, _ = surface options ~link_modules in
let prg = load_module_interfaces prg options link_modules in Message.emit_debug "- DESUGARED -";
Message.emit_debug "Name resolution..."; Message.emit_debug "Name resolution...";
let ctx = Desugared.Name_resolution.form_context prg in let ctx = Desugared.Name_resolution.form_context prg in
(* let scope_uid = get_scope_uid options backend ctx in (* let scope_uid = get_scope_uid options backend ctx in
@ -87,8 +92,8 @@ module Passes = struct
* Desugared.Name_resolution.context * Desugared.Name_resolution.context
* Desugared.Dependency.ExceptionsDependencies.t * Desugared.Dependency.ExceptionsDependencies.t
Desugared.Ast.ScopeDef.Map.t = Desugared.Ast.ScopeDef.Map.t =
Message.emit_debug "Collecting rules...";
let prg, ctx = desugared options ~link_modules in let prg, ctx = desugared options ~link_modules in
Message.emit_debug "- SCOPELANG -";
let exceptions_graphs = let exceptions_graphs =
Scopelang.From_desugared.build_exceptions_graph prg Scopelang.From_desugared.build_exceptions_graph prg
in in
@ -102,11 +107,12 @@ module Passes = struct
* Desugared.Name_resolution.context * Desugared.Name_resolution.context
* Scopelang.Dependency.TVertex.t list = * Scopelang.Dependency.TVertex.t list =
let prg, ctx, _ = scopelang options ~link_modules in let prg, ctx, _ = scopelang options ~link_modules in
Message.emit_debug "Typechecking..."; Message.emit_debug "- DCALC -";
let type_ordering = let type_ordering =
Scopelang.Dependency.check_type_cycles prg.program_ctx.ctx_structs Scopelang.Dependency.check_type_cycles prg.program_ctx.ctx_structs
prg.program_ctx.ctx_enums prg.program_ctx.ctx_enums
in in
Message.emit_debug "Typechecking...";
let prg = Scopelang.Ast.type_program prg in let prg = Scopelang.Ast.type_program prg in
Message.emit_debug "Translating to default calculus..."; Message.emit_debug "Translating to default calculus...";
let prg = Dcalc.From_scopelang.translate_program prg in let prg = Dcalc.From_scopelang.translate_program prg in
@ -147,7 +153,7 @@ module Passes = struct
let prg, ctx, type_ordering = let prg, ctx, type_ordering =
dcalc options ~link_modules ~optimize ~check_invariants dcalc options ~link_modules ~optimize ~check_invariants
in in
Message.emit_debug "Compiling program into lambda calculus..."; Message.emit_debug "- LCALC -";
let avoid_exceptions = avoid_exceptions || closure_conversion in let avoid_exceptions = avoid_exceptions || closure_conversion in
let optimize = optimize || closure_conversion in let optimize = optimize || closure_conversion in
(* --closure_conversion implies --avoid_exceptions and --optimize *) (* --closure_conversion implies --avoid_exceptions and --optimize *)
@ -198,7 +204,7 @@ module Passes = struct
lcalc options ~link_modules ~optimize ~check_invariants ~avoid_exceptions lcalc options ~link_modules ~optimize ~check_invariants ~avoid_exceptions
~closure_conversion ~closure_conversion
in in
Message.emit_debug "Compiling program into statement calculus..."; Message.emit_debug "- SCALC -";
Scalc.From_lcalc.translate_program prg, ctx, type_ordering Scalc.From_lcalc.translate_program prg, ctx, type_ordering
end end
@ -261,6 +267,12 @@ module Commands = struct
SubScopeName.format subscope_var_name ScopeName.format scope_uid SubScopeName.format subscope_var_name ScopeName.format scope_uid
| Some second_part -> ( | Some second_part -> (
match 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 Ident.Map.find_opt second_part
(ScopeName.Map.find subscope_name ctxt.scopes).var_idmap (ScopeName.Map.find subscope_name ctxt.scopes).var_idmap
with with
@ -299,7 +311,7 @@ module Commands = struct
~output_file ?ext () ~output_file ?ext ()
let makefile options output = 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 backend_extensions_list = [".tex"] in
let source_file = let source_file =
match options.Cli.input_file with match options.Cli.input_file with
@ -330,7 +342,7 @@ module Commands = struct
Term.(const makefile $ Cli.Flags.Global.options $ Cli.Flags.output) Term.(const makefile $ Cli.Flags.Global.options $ Cli.Flags.output)
let html options output print_only_law wrap_weaved_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"; Message.emit_debug "Weaving literate program into HTML";
let output_file, with_output = let output_file, with_output =
get_output_format options ~ext:".html" output get_output_format options ~ext:".html" output
@ -358,7 +370,7 @@ module Commands = struct
$ Cli.Flags.wrap_weaved_output) $ Cli.Flags.wrap_weaved_output)
let latex options output print_only_law 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"; Message.emit_debug "Weaving literate program into LaTeX";
let output_file, with_output = let output_file, with_output =
get_output_format options ~ext:".tex" output get_output_format options ~ext:".tex" output
@ -559,10 +571,10 @@ module Commands = struct
results results
let interpret_dcalc options link_modules optimize check_invariants ex_scope = let interpret_dcalc options link_modules optimize check_invariants ex_scope =
Interpreter.load_runtime_modules link_modules;
let prg, ctx, _ = let prg, ctx, _ =
Passes.dcalc options ~link_modules ~optimize ~check_invariants Passes.dcalc options ~link_modules ~optimize ~check_invariants
in in
Interpreter.load_runtime_modules link_modules;
print_interpretation_results options Interpreter.interpret_program_dcalc prg print_interpretation_results options Interpreter.interpret_program_dcalc prg
(get_scope_uid ctx ex_scope) (get_scope_uid ctx ex_scope)
@ -887,6 +899,7 @@ let main () =
| Some opts, _ -> opts.Cli.plugins_dirs | Some opts, _ -> opts.Cli.plugins_dirs
| None, _ -> [] | None, _ -> []
in in
Message.emit_debug "- INIT -";
List.iter List.iter
(fun d -> (fun d ->
if d = "" then () 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 Each pass takes only its cli options, then calls upon its dependent passes
(forwarding their options as needed) *) (forwarding their options as needed) *)
module Passes : sig 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 : val desugared :
Cli.options -> Cli.options ->

19
compiler/lcalc/ast.ml
View File

@ -23,10 +23,11 @@ type 'm program = 'm expr Shared_ast.program
module OptionMonad = struct module OptionMonad = struct
let return ~(mark : 'a mark) e = 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) = 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 bind_var ~(mark : 'a mark) f x arg =
let cases = let cases =
@ -36,8 +37,8 @@ module OptionMonad = struct
let x = Var.make "_" in let x = Var.make "_" in
Expr.eabs Expr.eabs
(Expr.bind [| x |] (Expr.bind [| x |]
(Expr.einj (Expr.evar x mark) Expr.none_constr Expr.option_enum (Expr.einj ~e:(Expr.evar x mark) ~cons:Expr.none_constr
mark)) ~name:Expr.option_enum mark))
[TLit TUnit, Expr.mark_pos mark] [TLit TUnit, Expr.mark_pos mark]
mark ); mark );
(* | None x -> None x *) (* | None x -> None x *)
@ -46,7 +47,7 @@ module OptionMonad = struct
(*| Some x -> f (where f contains x as a free variable) *); (*| Some x -> f (where f contains x as a free variable) *);
] ]
in 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 bind ~(mark : 'a mark) ~(var_name : string) f arg =
let x = Var.make var_name in let x = Var.make var_name in
@ -86,8 +87,8 @@ module OptionMonad = struct
ListLabels.fold_left2 xs args ~f:(bind_var ~mark) ListLabels.fold_left2 xs args ~f:(bind_var ~mark)
~init: ~init:
(Expr.einj (Expr.einj
(Expr.eapp f (List.map (fun v -> Expr.evar v mark) xs) mark) ~e:(Expr.eapp f (List.map (fun v -> Expr.evar v mark) xs) mark)
Expr.some_constr Expr.option_enum 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 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*); Expr.some_constr, Expr.fun_id ~var_name mark (* | Some x -> x*);
] ]
in in
if toplevel then 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 arg Expr.option_enum cases mark) else return ~mark (Expr.ematch ~e:arg ~name:Expr.option_enum ~cases mark)
end end

6
compiler/lcalc/closure_conversion.ml
View File

@ -70,7 +70,7 @@ let rec transform_closures_expr :
cases cases
(free_vars, EnumConstructor.Map.empty) (free_vars, EnumConstructor.Map.empty)
in 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 } -> | EApp { f = EAbs { binder; tys }, e1_pos; args } ->
(* let-binding, we should not close these *) (* let-binding, we should not close these *)
let vars, body = Bindlib.unmbind binder in let vars, body = Bindlib.unmbind binder in
@ -394,7 +394,7 @@ let rec hoist_closures_expr :
cases cases
(collected_closures, EnumConstructor.Map.empty) (collected_closures, EnumConstructor.Map.empty)
in 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 } -> | EApp { f = EAbs { binder; tys }, e1_pos; args } ->
(* let-binding, we should not close these *) (* let-binding, we should not close these *)
let vars, body = Bindlib.unmbind binder in let vars, body = Bindlib.unmbind binder in
@ -552,7 +552,7 @@ let rec hoist_closures_code_item_list
(fun next_code_items closure -> (fun next_code_items closure ->
Cons Cons
( Topdef ( Topdef
( TopdefName.fresh ( TopdefName.fresh []
( Bindlib.name_of hoisted_closure.name, ( Bindlib.name_of hoisted_closure.name,
Expr.mark_pos closure_mark ), Expr.mark_pos closure_mark ),
hoisted_closure.ty, 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 if (Var.Map.find x ctx.ctx_vars).info_pure then
Ast.OptionMonad.return (Expr.evar (trans_var ctx x) m) ~mark Ast.OptionMonad.return (Expr.evar (trans_var ctx x) m) ~mark
else Expr.evar (trans_var ctx x) m 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, _)] } -> | EApp { f = EVar v, _; args = [(ELit LUnit, _)] } ->
(* Invariant: as users cannot write thunks, it can only come from prior (* Invariant: as users cannot write thunks, it can only come from prior
compilation passes. Hence we can safely remove those. *) 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 Ast.OptionMonad.return ~mark
(Expr.eapp (Expr.eapp
(Expr.evar (trans_var ctx scope) mark) (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) mark)
| EApp { f = (EVar ff, _) as f; args } | EApp { f = (EVar ff, _) as f; args }
when not (Var.Map.find ff ctx.ctx_vars).is_scope -> 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 in
Ast.OptionMonad.bind_cont Ast.OptionMonad.bind_cont
~var_name:(context_or_same_var ctx e) ~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 (trans ctx e) ~mark
| EArray args -> | EArray args ->
Ast.OptionMonad.mbind_cont ~mark ~var_name:ctx.ctx_context_name 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) xs)
~f:StructField.Map.add ~init:StructField.Map.empty ~f:StructField.Map.add ~init:StructField.Map.empty
in in
Ast.OptionMonad.return ~mark (Expr.estruct name fields mark)) Ast.OptionMonad.return ~mark (Expr.estruct ~name ~fields mark))
(List.map (trans ctx) fields) (List.map (trans ctx) fields)
~mark ~mark
| EIfThenElse { cond; etrue; efalse } -> | 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) ~var_name:(context_or_same_var ctx e)
(fun e -> (fun e ->
Ast.OptionMonad.return ~mark 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 (trans ctx e) ~mark
| EStructAccess { name; e; field } -> | EStructAccess { name; e; field } ->
Ast.OptionMonad.bind_cont Ast.OptionMonad.bind_cont
~var_name:(context_or_same_var ctx e) ~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 (trans ctx e) ~mark
| ETuple args -> | ETuple args ->
Ast.OptionMonad.mbind_cont ~var_name:ctx.ctx_context_name Ast.OptionMonad.mbind_cont ~var_name:ctx.ctx_context_name
@ -653,8 +657,8 @@ and trans_scope_body_expr ctx s :
Bindlib.box_apply Bindlib.box_apply
(fun e -> Result e) (fun e -> Result e)
(Expr.Box.lift (Expr.Box.lift
@@ Expr.estruct name @@ Expr.estruct ~name
(StructField.Map.map (trans ctx) fields) ~fields:(StructField.Map.map (trans ctx) fields)
(Mark.get e)) (Mark.get e))
| _ -> assert false | _ -> assert false
end end

75
compiler/lcalc/to_ocaml.ml
View File

@ -19,22 +19,6 @@ open Shared_ast
open Ast open Ast
module D = Dcalc.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 = let format_lit (fmt : Format.formatter) (l : lit Mark.pos) : unit =
match Mark.remove l with match Mark.remove l with
| LBool b -> Print.lit fmt (LBool b) | LBool b -> Print.lit fmt (LBool b)
@ -159,11 +143,7 @@ let format_to_module_name
| `Ename v -> Format.asprintf "%a" EnumName.format v | `Ename v -> Format.asprintf "%a" EnumName.format v
| `Sname v -> Format.asprintf "%a" StructName.format v) | `Sname v -> Format.asprintf "%a" StructName.format v)
|> String.to_ascii |> String.to_ascii
|> String.to_snake_case
|> avoid_keywords |> avoid_keywords
|> String.split_on_char '_'
|> List.map String.capitalize_ascii
|> String.concat ""
|> Format.fprintf fmt "%s" |> Format.fprintf fmt "%s"
let format_struct_field_name let format_struct_field_name
@ -233,10 +213,8 @@ let rec format_typ (fmt : Format.formatter) (typ : typ) : unit =
| TAny -> Format.fprintf fmt "_" | TAny -> Format.fprintf fmt "_"
| TClosureEnv -> failwith "unimplemented!" | TClosureEnv -> failwith "unimplemented!"
let format_var (fmt : Format.formatter) (v : 'm Var.t) : unit = let format_var_str (fmt : Format.formatter) (v : string) : unit =
let lowercase_name = let lowercase_name = String.to_snake_case (String.to_ascii v) in
String.to_snake_case (String.to_ascii (Bindlib.name_of v))
in
let lowercase_name = let lowercase_name =
Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.") Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.")
~subst:(fun _ -> "_dot_") ~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 let lowercase_name = String.to_ascii lowercase_name in
if if
List.mem lowercase_name ["handle_default"; "handle_default_opt"] 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 then Format.pp_print_string fmt lowercase_name
else if lowercase_name = "_" 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 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 = let needs_parens (e : 'm expr) : bool =
match Mark.remove e with match Mark.remove e with
| EApp { f = EAbs _, _; _ } | EApp { f = EAbs _, _; _ }
@ -288,7 +270,26 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
in in
match Mark.remove e with match Mark.remove e with
| EVar v -> Format.fprintf fmt "%a" format_var v | 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 -> | ETuple es ->
Format.fprintf fmt "@[<hov 2>(%a)@]" Format.fprintf fmt "@[<hov 2>(%a)@]"
(Format.pp_print_list (Format.pp_print_list
@ -471,7 +472,7 @@ let format_struct_embedding
StructName.format struct_name StructName.format struct_name
(Format.pp_print_list (Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n") ~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 Format.fprintf fmt "(\"%a\",@ %a@ x.%a)" StructField.format
struct_field typ_embedding_name struct_field_type struct_field typ_embedding_name struct_field_type
format_struct_field_name format_struct_field_name
@ -493,7 +494,7 @@ let format_enum_embedding
EnumName.format enum_name EnumName.format enum_name
(Format.pp_print_list (Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") ~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.fprintf fmt "@[<hov 2>| %a x ->@ (\"%a\", %a x)@]"
format_enum_cons_name enum_cons EnumConstructor.format enum_cons format_enum_cons_name enum_cons EnumConstructor.format enum_cons
typ_embedding_name enum_cons_type)) typ_embedding_name enum_cons_type))
@ -516,7 +517,7 @@ let format_ctx
format_to_module_name (`Sname struct_name) format_to_module_name (`Sname struct_name)
(Format.pp_print_list (Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ") ~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 Format.fprintf fmt "@[<hov 2>%a:@ %a@]" format_struct_field_name
(None, struct_field) format_typ struct_field_type)) (None, struct_field) format_typ struct_field_type))
(StructField.Map.bindings struct_fields); (StructField.Map.bindings struct_fields);
@ -529,7 +530,7 @@ let format_ctx
format_to_module_name (`Ename enum_name) format_to_module_name (`Ename enum_name)
(Format.pp_print_list (Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") ~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 Format.fprintf fmt "@[<hov 2>| %a@ of@ %a@]" format_enum_cons_name
enum_cons format_typ enum_cons_type)) enum_cons format_typ enum_cons_type))
(EnumConstructor.Map.bindings enum_cons); (EnumConstructor.Map.bindings enum_cons);
@ -555,9 +556,13 @@ let format_ctx
(fun struct_or_enum -> (fun struct_or_enum ->
match struct_or_enum with match struct_or_enum with
| Scopelang.Dependency.TVertex.Struct s -> | 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 -> | 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) (type_ordering @ scope_structs)
let rename_vars e = let rename_vars e =
@ -594,7 +599,7 @@ let format_code_items
| Topdef (name, typ, e) -> | Topdef (name, typ, e) ->
Format.fprintf fmt "@\n@\n@[<hov 2>let %a : %a =@\n%a@]" format_var var Format.fprintf fmt "@\n@\n@[<hov 2>let %a : %a =@\n%a@]" format_var var
format_typ typ (format_expr ctx) e; 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) -> | ScopeDef (name, body) ->
let scope_input_var, scope_body_expr = let scope_input_var, scope_body_expr =
Bindlib.unbind body.scope_body_expr Bindlib.unbind body.scope_body_expr
@ -605,7 +610,7 @@ let format_code_items
(`Sname body.scope_body_output_struct) (`Sname body.scope_body_output_struct)
(format_scope_body_expr ctx) (format_scope_body_expr ctx)
scope_body_expr; 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 ~init:String.Map.empty code_items
let format_scope_exec let format_scope_exec
@ -614,7 +619,7 @@ let format_scope_exec
(bnd : 'm Ast.expr Var.t String.Map.t) (bnd : 'm Ast.expr Var.t String.Map.t)
scope_name scope_name
scope_body = 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_var = String.Map.find scope_name_str bnd in
let scope_input = let scope_input =
StructName.Map.find scope_body.scope_body_input_struct ctx.ctx_structs 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 *) (** Formats a lambda calculus program into a valid OCaml program *)
val avoid_keywords : string -> string 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 typ_needs_parens : typ -> bool
(* val needs_parens : 'm expr -> 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) To_ocaml.format_to_module_name fmt (`Sname struct_name)
in in
let fmt_to_jsoo fmt _ = let fmt_to_jsoo fmt _ =
Format.fprintf fmt "%a" Format.pp_print_list
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n") (fun fmt (struct_field, struct_field_type) ->
(fun fmt (struct_field, struct_field_type) -> match Mark.remove struct_field_type with
match Mark.remove struct_field_type with | TArrow (t1, t2) ->
| TArrow (t1, t2) -> let args_names =
let args_names = ListLabels.mapi t1 ~f:(fun i _ ->
ListLabels.mapi t1 ~f:(fun i _ -> "function_input" ^ string_of_int i)
"function_input" ^ string_of_int i) in
in Format.fprintf fmt
Format.fprintf fmt "@[<hov 2>method %a =@ Js.wrap_meth_callback@ @[<hv 2>(@,\
"@[<hov 2>method %a =@ Js.wrap_meth_callback@ @[<hv 2>(@,\ fun _ %a ->@ %a (%a.%a %a))@]@]"
fun _ %a ->@ %a (%a.%a %a))@]@]" format_struct_field_name_camel_case struct_field
format_struct_field_name_camel_case struct_field (Format.pp_print_list (fun fmt (arg_i, ti) ->
(Format.pp_print_list (fun fmt (arg_i, ti) -> Format.fprintf fmt "(%s: %a)" arg_i format_typ ti))
Format.fprintf fmt "(%s: %a)" arg_i format_typ ti)) (List.combine args_names t1)
(List.combine args_names t1) format_typ_to_jsoo t2 fmt_struct_name ()
format_typ_to_jsoo t2 fmt_struct_name () format_struct_field_name (None, struct_field)
format_struct_field_name (None, struct_field) (Format.pp_print_list (fun fmt (i, ti) ->
(Format.pp_print_list (fun fmt (i, ti) -> Format.fprintf fmt "@[<hv 2>(%a@ %a)@]" format_typ_of_jsoo
Format.fprintf fmt "@[<hv 2>(%a@ %a)@]" ti Format.pp_print_string i))
format_typ_of_jsoo ti Format.pp_print_string i)) (List.combine args_names t1)
(List.combine args_names t1) | _ ->
| _ -> Format.fprintf fmt "@[<hov 2>val %a =@ %a %a.%a@]"
Format.fprintf fmt "@[<hov 2>val %a =@ %a %a.%a@]" format_struct_field_name_camel_case struct_field
format_struct_field_name_camel_case struct_field format_typ_to_jsoo struct_field_type fmt_struct_name ()
format_typ_to_jsoo struct_field_type fmt_struct_name () format_struct_field_name (None, struct_field))
format_struct_field_name (None, struct_field))) fmt
(StructField.Map.bindings struct_fields) (StructField.Map.bindings struct_fields)
in in
let fmt_of_jsoo fmt _ = let fmt_of_jsoo fmt _ =
Format.fprintf fmt "%a" Format.pp_print_list
(Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n")
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n") (fun fmt (struct_field, struct_field_type) ->
(fun fmt (struct_field, struct_field_type) -> match Mark.remove struct_field_type with
match Mark.remove struct_field_type with | TArrow _ ->
| TArrow _ -> Format.fprintf fmt
Format.fprintf fmt "%a = failwith \"The function '%a' translation isn't yet \
"%a = failwith \"The function '%a' translation isn't yet \ supported...\""
supported...\"" format_struct_field_name (None, struct_field)
format_struct_field_name (None, struct_field) format_struct_field_name (None, struct_field)
format_struct_field_name (None, struct_field) | _ ->
| _ -> Format.fprintf fmt
Format.fprintf fmt "@[<hv 2>%a =@ @[<hov 2>%a@ @[<hov>%a@,##.%a@]@]@]"
"@[<hv 2>%a =@ @[<hov 2>%a@ @[<hov>%a@,##.%a@]@]@]" format_struct_field_name (None, struct_field) format_typ_of_jsoo
format_struct_field_name (None, struct_field) struct_field_type fmt_struct_name ()
format_typ_of_jsoo struct_field_type fmt_struct_name () format_struct_field_name_camel_case struct_field)
format_struct_field_name_camel_case struct_field)) fmt
(StructField.Map.bindings struct_fields) (StructField.Map.bindings struct_fields)
in in
let fmt_conv_funs fmt _ = 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 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_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) To_ocaml.format_to_module_name fmt (`Ename enum_name)
in in
let fmt_to_jsoo fmt _ = let fmt_to_jsoo fmt _ =
@ -332,9 +332,11 @@ module To_jsoo = struct
(fun struct_or_enum -> (fun struct_or_enum ->
match struct_or_enum with match struct_or_enum with
| Scopelang.Dependency.TVertex.Struct s -> | 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 -> | 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) (type_ordering @ scope_structs)
let fmt_input_struct_name fmt (scope_body : 'a expr scope_body) = 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 = let env_elt =
try Env.find 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 error e0 "Variable %a undefined [@[<hv>%a@]]" Print.var_debug v
Env.print env Env.print env
in in
@ -689,7 +689,7 @@ let program_to_graph
(G.add_vertex g v, var_vertices, env0), v (G.add_vertex g v, var_vertices, env0), v
| EVar var, _ -> ( | EVar var, _ -> (
try (g, var_vertices, env0), Var.Map.find var var_vertices try (g, var_vertices, env0), Var.Map.find var var_vertices
with Not_found -> ( with Var.Map.Not_found _ -> (
try try
let child, env = (Env.find var env0).base in let child, env = (Env.find var env0).base in
let m = Mark.get child in let m = Mark.get child in
@ -714,7 +714,7 @@ let program_to_graph
else Var.Map.add var v var_vertices else Var.Map.add var v var_vertices
in in
(G.add_edge g v child_v, var_vertices, env), v (G.add_edge g v child_v, var_vertices, env), v
with Not_found -> with Var.Map.Not_found _ ->
Message.emit_warning "VAR NOT FOUND: %a" Print.var var; Message.emit_warning "VAR NOT FOUND: %a" Print.var var;
let v = G.V.create e in let v = G.V.create e in
let g = G.add_vertex g v in let g = G.add_vertex g v in

7
compiler/plugins/json_schema.ml
View File

@ -76,13 +76,14 @@ module To_json = struct
(ctx : decl_ctx) (ctx : decl_ctx)
(fmt : Format.formatter) (fmt : Format.formatter)
(sname : StructName.t) = (sname : StructName.t) =
let fields = StructName.Map.find sname ctx.ctx_structs in
Format.pp_print_list Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n") ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n")
(fun fmt (field_name, field_type) -> (fun fmt (field_name, field_type) ->
Format.fprintf fmt "@[<hov 2>\"%a\": {@\n%a@]@\n}" Format.fprintf fmt "@[<hov 2>\"%a\": {@\n%a@]@\n}"
format_struct_field_name_camel_case field_name fmt_type field_type) format_struct_field_name_camel_case field_name fmt_type field_type)
fmt fmt
(StructField.Map.bindings (find_struct sname ctx)) (StructField.Map.bindings fields)
let fmt_definitions let fmt_definitions
(ctx : decl_ctx) (ctx : decl_ctx)
@ -107,13 +108,13 @@ module To_json = struct
| TArray t -> collect acc t | TArray t -> collect acc t
| _ -> acc | _ -> acc
in in
find_struct input_struct ctx StructName.Map.find input_struct ctx.ctx_structs
|> StructField.Map.values |> StructField.Map.values
|> List.fold_left (fun acc field_typ -> collect acc field_typ) [] |> 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')) |> List.sort_uniq (fun t t' -> String.compare (get_name t) (get_name t'))
in in
let fmt_enum_properties fmt ename = 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 Format.fprintf fmt
"@[<hov 2>\"kind\": {@\n\ "@[<hov 2>\"kind\": {@\n\
\"type\": \"string\",@\n\ \"type\": \"string\",@\n\

23
compiler/plugins/lazy_interp.ml
View File

@ -75,7 +75,7 @@ let rec lazy_eval :
(?) *) (?) *)
let v_env = let v_env =
try Env.find 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 error e0 "Variable %a undefined [@[<hv>%a@]]" Print.var_debug v
Env.print env Env.print env
in in
@ -233,16 +233,17 @@ let interpret_program (prg : ('dcalc, 'm) gexpr program) (scope : ScopeName.t) :
log "====================="; log "=====================";
let m = Mark.get e in let m = Mark.get e in
let application_arg = let application_arg =
Expr.estruct scope_arg_struct Expr.estruct ~name:scope_arg_struct
(StructField.Map.map ~fields:
(function (StructField.Map.map
| TArrow (ty_in, ty_out), _ -> (function
Expr.make_abs | TArrow (ty_in, ty_out), _ ->
[| Var.make "_" |] Expr.make_abs
(Bindlib.box EEmptyError, Expr.with_ty m ty_out) [| Var.make "_" |]
ty_in (Expr.mark_pos m) (Bindlib.box EEmptyError, Expr.with_ty m ty_out)
| ty -> Expr.evar (Var.make "undefined_input") (Expr.with_ty m ty)) ty_in (Expr.mark_pos m)
(StructName.Map.find scope_arg_struct ctx.ctx_structs)) | ty -> Expr.evar (Var.make "undefined_input") (Expr.with_ty m ty))
(StructName.Map.find scope_arg_struct ctx.ctx_structs))
m m
in in
let e_app = Expr.eapp (Expr.box e) [application_arg] 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 \ "Could not locate the OCaml library directory, make sure OCaml or \
opam is installed"))) 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 = let runtime_dir =
lazy lazy
(match (let d =
List.find_map File.check_directory match find_catala_project_root (Sys.getcwd ()) with
[ | Some root ->
"_build/install/default/lib/catala/runtime_ocaml"; (* Relative dir when running from catala source *)
(* Relative dir when running from catala source *) File.(
File.(Lazy.force ocaml_libdir / "catala" / "runtime"); root
] / "_build"
with / "install"
| Some dir -> / "default"
Message.emit_debug "Catala runtime libraries found at @{<bold>%s@}." dir; / "lib"
dir / "catala"
| None -> / "runtime_ocaml")
Message.raise_error | None -> File.(Lazy.force ocaml_libdir / "catala" / "runtime")
"Could not locate the Catala runtime library.@ Make sure that either \ in
catala is correctly installed,@ or you are running from the root of a \ match File.check_directory d with
compiled source tree.") | 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 compile options link_modules optimize check_invariants =
let modname = 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 gen_ocaml options link_modules optimize check_invariants (Some modname) None
in in
let flags = ["-I"; Lazy.force runtime_dir] 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@}..." Message.emit_debug "Compiling OCaml shared object file @{<bold>%s@}..."
shared_out; shared_out;
run_process "ocamlopt" ("-shared" :: ml_file :: "-o" :: shared_out :: flags); 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 -> | EVar v ->
let local_var = let local_var =
try A.EVar (Var.Map.find v ctxt.var_dict) 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) 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) Message.raise_spanned_error (Expr.pos expr)
"Var not found in lambda→scalc: %a@\nknown: @[<hov>%a@]@\n" "Var not found in lambda→scalc: %a@\nknown: @[<hov>%a@]@\n"
Print.var_debug v Print.var_debug v

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 | EVar v -> Format.fprintf fmt "%a" format_var_name v
| EFunc v -> Format.fprintf fmt "%a" format_func_name v | EFunc v -> Format.fprintf fmt "%a" format_func_name v
| EStruct (es, s) -> | 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 Format.fprintf fmt "@[<hov 2>%a@ %a%a%a@]" StructName.format s
Print.punctuation "{" Print.punctuation "{"
(Format.pp_print_list (Format.pp_print_list
@ -50,8 +51,7 @@ let rec format_expr
Format.fprintf fmt "%a%a%a%a %a" Print.punctuation "\"" Format.fprintf fmt "%a%a%a%a %a" Print.punctuation "\""
StructField.format struct_field Print.punctuation "\"" StructField.format struct_field Print.punctuation "\""
Print.punctuation ":" format_expr e)) Print.punctuation ":" format_expr e))
(List.combine es (List.combine es (StructField.Map.bindings fields))
(StructField.Map.bindings (StructName.Map.find s decl_ctx.ctx_structs)))
Print.punctuation "}" Print.punctuation "}"
| EArray es -> | EArray es ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" Print.punctuation "[" Format.fprintf fmt "@[<hov 2>%a%a%a@]" Print.punctuation "["
@ -142,6 +142,7 @@ let rec format_statement
(format_expr decl_ctx ~debug) (format_expr decl_ctx ~debug)
(naked_expr, Mark.get stmt) (naked_expr, Mark.get stmt)
| SSwitch (e_switch, enum, arms) -> | 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.fprintf fmt "@[<v 0>%a @[<hov 2>%a@]%a@]%a" Print.keyword "switch"
(format_expr decl_ctx ~debug) (format_expr decl_ctx ~debug)
e_switch Print.punctuation ":" e_switch Print.punctuation ":"
@ -153,10 +154,7 @@ let rec format_statement
format_var_name payload_name Print.punctuation "→" format_var_name payload_name Print.punctuation "→"
(format_block decl_ctx ~debug) (format_block decl_ctx ~debug)
arm_block)) arm_block))
(List.combine (List.combine (EnumConstructor.Map.bindings cons) arms)
(EnumConstructor.Map.bindings
(EnumName.Map.find enum decl_ctx.ctx_enums))
arms)
and format_block and format_block
(decl_ctx : decl_ctx) (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 | EVar v -> format_var fmt v
| EFunc f -> format_func_name fmt f | EFunc f -> format_func_name fmt f
| EStruct (es, s) -> | EStruct (es, s) ->
let fields = StructName.Map.find s ctx.ctx_structs in
Format.fprintf fmt "%a(%a)" format_struct_name s Format.fprintf fmt "%a(%a)" format_struct_name s
(Format.pp_print_list (Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt (e, (struct_field, _)) -> (fun fmt (e, (struct_field, _)) ->
Format.fprintf fmt "%a = %a" format_struct_field_name struct_field Format.fprintf fmt "%a = %a" format_struct_field_name struct_field
(format_expression ctx) e)) (format_expression ctx) e))
(List.combine es (List.combine es (StructField.Map.bindings fields))
(StructField.Map.bindings (StructName.Map.find s ctx.ctx_structs)))
| EStructFieldAccess (e1, field, _) -> | EStructFieldAccess (e1, field, _) ->
Format.fprintf fmt "%a.%a" (format_expression ctx) e1 Format.fprintf fmt "%a.%a" (format_expression ctx) e1
format_struct_field_name field 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_none format_var case_some_var format_var tmp_var
(format_block ctx) case_some (format_block ctx) case_some
| SSwitch (e1, e_name, cases) -> | SSwitch (e1, e_name, cases) ->
let cons_map = EnumName.Map.find e_name ctx.ctx_enums in
let cases = let cases =
List.map2 List.map2
(fun (x, y) (cons, _) -> x, y, cons) (fun (x, y) (cons, _) -> x, y, cons)
cases cases
(EnumConstructor.Map.bindings (EnumName.Map.find e_name ctx.ctx_enums)) (EnumConstructor.Map.bindings cons_map)
in in
let tmp_var = VarName.fresh ("match_arg", Pos.no_pos) 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 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_decl_name : ScopeName.t;
scope_sig : (typ * Desugared.Ast.io) ScopeVar.Map.t; scope_sig : (typ * Desugared.Ast.io) ScopeVar.Map.t;
scope_decl_rules : 'm rule list; scope_decl_rules : 'm rule list;
scope_mark : 'm mark;
scope_options : Desugared.Ast.catala_option Mark.pos list; scope_options : Desugared.Ast.catala_option Mark.pos list;
} }
type 'm program = { 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_topdefs : ('m expr * typ) TopdefName.Map.t;
program_modules : nil program ModuleName.Map.t;
program_ctx : decl_ctx; 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 }) Call (sc_name, ssc_name, Typed { pos; ty = Mark.add pos TAny })
let type_program (prg : 'm program) : typed program = let type_program (prg : 'm program) : typed program =
let typing_env = (* Caution: this environment building code is very similar to that in
TopdefName.Map.fold desugared/disambiguate.ml. Any edits should probably be reflected. *)
(fun name (_, ty) -> Typing.Env.add_toplevel_var name ty) let base_typing_env prg =
prg.program_topdefs let env = Typing.Env.empty prg.program_ctx in
(Typing.Env.empty prg.program_ctx) 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 in
let program_topdefs = let program_topdefs =
TopdefName.Map.map TopdefName.Map.map
(fun (expr, typ) -> (fun (expr, typ) ->
( Expr.unbox ( Expr.unbox
(Typing.expr prg.program_ctx ~leave_unresolved:false ~env:typing_env (Typing.expr prg.program_ctx ~leave_unresolved:false ~env ~typ expr),
~typ expr),
typ )) typ ))
prg.program_topdefs prg.program_topdefs
in 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 = let program_scopes =
ScopeName.Map.map ScopeName.Map.map
(fun scope_decl -> (Mark.map (fun scope_decl ->
let typing_env = let env =
ScopeVar.Map.fold ScopeVar.Map.fold
(fun svar (typ, _) env -> Typing.Env.add_scope_var svar typ env) (fun svar (typ, _) env -> Typing.Env.add_scope_var svar typ env)
scope_decl.scope_sig typing_env scope_decl.scope_sig env
in in
let scope_decl_rules = let scope_decl_rules =
List.map List.map
(type_rule prg.program_ctx typing_env) (type_rule prg.program_ctx env)
scope_decl.scope_decl_rules scope_decl.scope_decl_rules
in in
let scope_mark = { scope_decl with scope_decl_rules }))
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 })
prg.program_scopes prg.program_scopes
in in
{ prg with program_topdefs; program_scopes } { 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_decl_name : ScopeName.t;
scope_sig : (typ * Desugared.Ast.io) ScopeVar.Map.t; scope_sig : (typ * Desugared.Ast.io) ScopeVar.Map.t;
scope_decl_rules : 'm rule list; scope_decl_rules : 'm rule list;
scope_mark : 'm mark;
scope_options : Desugared.Ast.catala_option Mark.pos list; scope_options : Desugared.Ast.catala_option Mark.pos list;
} }
type 'm program = { 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_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; program_ctx : decl_ctx;
} }

14
compiler/scopelang/dependency.ml
View File

@ -82,9 +82,12 @@ let rec expr_used_defs e =
e VMap.empty e VMap.empty
in in
match e with 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 -> | (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; _ }, _ -> | EAbs { binder; _ }, _ ->
let _, body = Bindlib.unmbind binder in let _, body = Bindlib.unmbind binder in
expr_used_defs body expr_used_defs body
@ -96,7 +99,10 @@ let rule_used_defs = function
walking through all exprs again *) walking through all exprs again *)
expr_used_defs e expr_used_defs e
| Ast.Call (subscope, subindex, _) -> | 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 build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t =
let g = SDependencies.empty in let g = SDependencies.empty in
@ -128,7 +134,7 @@ let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t =
prgm.program_topdefs g prgm.program_topdefs g
in in
ScopeName.Map.fold ScopeName.Map.fold
(fun scope_name scope g -> (fun scope_name (scope, _) g ->
List.fold_left List.fold_left
(fun g rule -> (fun g rule ->
let used_defs = rule_used_defs rule in 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 type t = Struct of StructName.t | Enum of EnumName.t
val format : Format.formatter -> t -> unit 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 include Graph.Sig.COMPARABLE with type t := t
end end

479
compiler/scopelang/from_desugared.ml
View File

@ -29,7 +29,8 @@ type target_scope_vars =
type ctx = { type ctx = {
decl_ctx : decl_ctx; decl_ctx : decl_ctx;
scope_var_mapping : target_scope_vars ScopeVar.Map.t; 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 let tag_with_log_entry
@ -42,8 +43,7 @@ let tag_with_log_entry
[e] (Mark.get e) [e] (Mark.get e)
else e else e
let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) : let rec translate_expr (ctx : ctx) (e : D.expr) : untyped Ast.expr boxed =
untyped Ast.expr boxed =
let m = Mark.get e in let m = Mark.get e in
match Mark.remove e with match Mark.remove e with
| EVar v -> Expr.evar (Var.Map.find v ctx.var_mapping) m | 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) ctx (Array.to_list vars) (Array.to_list new_vars)
in in
Expr.eabs (Expr.bind new_vars (translate_expr ctx body)) tys m 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 (* When referring to a subscope variable in an expression, we are referring
to the output, hence we take the last state. *) to the output, hence we take the last state. *)
let new_s_var = let ctx =
match ScopeVar.Map.find (Mark.remove s_var) ctx.scope_var_mapping with List.fold_left
| WholeVar new_s_var -> Mark.copy s_var new_s_var (fun ctx m -> ModuleName.Map.find m ctx.modules)
| States states -> Mark.copy s_var (snd (List.hd (List.rev states))) ctx (ScopeName.path scope)
in in
Expr.elocation (SubScopeVar (s_name, ss_name, new_s_var)) m let var =
| ELocation (DesugaredScopeVar (s_var, None)) -> 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 Expr.elocation
(ScopelangScopeVar (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 name =
| States _ -> failwith "should not happen")) (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 m
| ELocation (DesugaredScopeVar (s_var, Some state)) -> | ELocation (DesugaredScopeVar { name; state = Some state }) ->
Expr.elocation Expr.elocation
(ScopelangScopeVar (ScopelangScopeVar
(match ScopeVar.Map.find (Mark.remove s_var) ctx.scope_var_mapping with {
| WholeVar _ -> failwith "should not happen" name =
| States states -> Mark.copy s_var (List.assoc state states))) (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 m
| ELocation (ToplevelVar v) -> Expr.elocation (ToplevelVar v) m | ELocation (ToplevelVar v) -> Expr.elocation (ToplevelVar v) m
| EDStructAccess { name_opt = None; _ } -> | EDStructAccess { name_opt = None; _ } ->
@ -93,29 +108,30 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) :
try try
StructName.Map.find name StructName.Map.find name
(Ident.Map.find field ctx.decl_ctx.ctx_struct_fields) (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 *) (* Should not happen after disambiguation *)
Message.raise_spanned_error (Expr.mark_pos m) Message.raise_spanned_error (Expr.mark_pos m)
"Field @{<yellow>\"%s\"@} does not belong to structure \ "Field @{<yellow>\"%s\"@} does not belong to structure \
@{<yellow>\"%a\"@}" @{<yellow>\"%a\"@}"
field StructName.format name field StructName.format name
in in
Expr.estructaccess e' field name m Expr.estructaccess ~e:e' ~field ~name m
| EScopeCall { scope; args } -> | EScopeCall { scope; args } ->
Expr.escopecall scope Expr.escopecall ~scope
(ScopeVar.Map.fold ~args:
(fun v e args' -> (ScopeVar.Map.fold
let v' = (fun v e args' ->
match ScopeVar.Map.find v ctx.scope_var_mapping with let v' =
| WholeVar v' -> v' match ScopeVar.Map.find v ctx.scope_var_mapping with
| States ((_, v') :: _) -> | WholeVar v' -> v'
(* When there are multiple states, the input is always the first | States ((_, v') :: _) ->
one *) (* When there are multiple states, the input is always the
v' first one *)
| States [] -> assert false v'
in | States [] -> assert false
ScopeVar.Map.add v' (translate_expr ctx e) args') in
args ScopeVar.Map.empty) ScopeVar.Map.add v' (translate_expr ctx e) args')
args ScopeVar.Map.empty)
m m
| EApp { f = EOp { op; tys }, m1; args } -> | EApp { f = EOp { op; tys }, m1; args } ->
let args = List.map (translate_expr ctx) args in 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] *) | EOp _ -> assert false (* Only allowed within [EApp] *)
| ( EStruct _ | ETuple _ | ETupleAccess _ | EInj _ | EMatch _ | ELit _ | ( EStruct _ | ETuple _ | ETupleAccess _ | EInj _ | EMatch _ | ELit _
| EApp _ | EDefault _ | EIfThenElse _ | EArray _ | EEmptyError | EApp _ | EDefault _ | EIfThenElse _ | EArray _ | EEmptyError
| EErrorOnEmpty _ | EExternal _ ) as e -> | EErrorOnEmpty _ ) as e ->
Expr.map ~f:(translate_expr ctx) (e, m) Expr.map ~f:(translate_expr ctx) (e, m)
(** {1 Rule tree construction} *) (** {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 (** Intermediate representation for the exception tree of rules for a particular
scope definition. *) scope definition. *)
type rule_tree = type rule_tree =
| Leaf of Desugared.Ast.rule list | Leaf of D.rule list
(** Rules defining a base case piecewise. List is non-empty. *) (** 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 (** [Node (exceptions, base_case)] is a list of exceptions to a non-empty
list of rules defining a base case piecewise. *) list of rules defining a base case piecewise. *)
(** Transforms a flat list of rules into a tree, taking into account the (** Transforms a flat list of rules into a tree, taking into account the
priorities declared between rules *) priorities declared between rules *)
let def_to_exception_graph let def_to_exception_graph
(def_info : Desugared.Ast.ScopeDef.t) (def_info : D.ScopeDef.t)
(def : Desugared.Ast.rule RuleName.Map.t) : (def : D.rule RuleName.Map.t) :
Desugared.Dependency.ExceptionsDependencies.t = Desugared.Dependency.ExceptionsDependencies.t =
let exc_graph = Desugared.Dependency.build_exceptions_graph def def_info in let exc_graph = Desugared.Dependency.build_exceptions_graph def def_info in
Desugared.Dependency.check_for_exception_cycle def exc_graph; Desugared.Dependency.check_for_exception_cycle def exc_graph;
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) -> ( | Desugared.Dependency.Vertex.Var (var, state) -> (
let scope_def = let scope_def =
Desugared.Ast.ScopeDef.Map.find D.ScopeDef.Map.find (D.ScopeDef.Var (var, state)) scope.scope_defs
(Desugared.Ast.ScopeDef.Var (var, state))
scope.scope_defs
in in
let var_def = scope_def.D.scope_def_rules 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) -> | OnlyInput when not (RuleName.Map.is_empty var_def) ->
(* If the variable is tagged as input, then it shall not be redefined. *) (* If the variable is tagged as input, then it shall not be redefined. *)
Message.raise_multispanned_error Message.raise_multispanned_error
@ -176,49 +190,43 @@ let rule_to_exception_graph (scope : Desugared.Ast.scope) = function
(RuleName.Map.keys var_def)) (RuleName.Map.keys var_def))
"It is impossible to give a definition to a scope variable tagged as \ "It is impossible to give a definition to a scope variable tagged as \
input." input."
| OnlyInput -> Desugared.Ast.ScopeDef.Map.empty | OnlyInput -> D.ScopeDef.Map.empty
(* we do not provide any definition for an input-only variable *) (* we do not provide any definition for an input-only variable *)
| _ -> | _ ->
Desugared.Ast.ScopeDef.Map.singleton D.ScopeDef.Map.singleton
(Desugared.Ast.ScopeDef.Var (var, state)) (D.ScopeDef.Var (var, state))
(def_to_exception_graph (def_to_exception_graph (D.ScopeDef.Var (var, state)) var_def))
(Desugared.Ast.ScopeDef.Var (var, state))
var_def))
| Desugared.Dependency.Vertex.SubScope sub_scope_index -> | Desugared.Dependency.Vertex.SubScope sub_scope_index ->
(* Before calling the sub_scope, we need to include all the re-definitions (* Before calling the sub_scope, we need to include all the re-definitions
of subscope parameters*) of subscope parameters*)
let sub_scope_vars_redefs_candidates = let sub_scope_vars_redefs_candidates =
Desugared.Ast.ScopeDef.Map.filter D.ScopeDef.Map.filter
(fun def_key scope_def -> (fun def_key scope_def ->
match def_key with match def_key with
| Desugared.Ast.ScopeDef.Var _ -> false | D.ScopeDef.Var _ -> false
| Desugared.Ast.ScopeDef.SubScopeVar (sub_scope_index', _, _) -> | D.ScopeDef.SubScopeVar (sub_scope_index', _, _) ->
sub_scope_index = sub_scope_index' sub_scope_index = sub_scope_index'
(* We exclude subscope variables that have 0 re-definitions and are (* We exclude subscope variables that have 0 re-definitions and are
not visible in the input of the subscope *) not visible in the input of the subscope *)
&& not && not
((match ((match Mark.remove scope_def.D.scope_def_io.io_input with
Mark.remove scope_def.Desugared.Ast.scope_def_io.io_input
with
| NoInput -> true | NoInput -> true
| _ -> false) | _ -> false)
&& RuleName.Map.is_empty scope_def.scope_def_rules)) && RuleName.Map.is_empty scope_def.scope_def_rules))
scope.scope_defs scope.scope_defs
in in
let sub_scope_vars_redefs = let sub_scope_vars_redefs =
Desugared.Ast.ScopeDef.Map.mapi D.ScopeDef.Map.mapi
(fun def_key scope_def -> (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 let is_cond = scope_def.scope_def_is_condition in
match def_key with match def_key with
| Desugared.Ast.ScopeDef.Var _ -> assert false (* should not happen *) | D.ScopeDef.Var _ -> assert false (* should not happen *)
| Desugared.Ast.ScopeDef.SubScopeVar (sscope, sub_scope_var, pos) -> | D.ScopeDef.SubScopeVar (sscope, sub_scope_var, pos) ->
(* This definition redefines a variable of the correct subscope. But (* This definition redefines a variable of the correct subscope. But
we have to check that this redefinition is allowed with respect we have to check that this redefinition is allowed with respect
to the io parameters of that subscope variable. *) to the io parameters of that subscope variable. *)
(match (match Mark.remove scope_def.D.scope_def_io.io_input with
Mark.remove scope_def.Desugared.Ast.scope_def_io.io_input
with
| NoInput -> | NoInput ->
Message.raise_multispanned_error Message.raise_multispanned_error
(( Some "Incriminated subscope:", (( Some "Incriminated subscope:",
@ -245,23 +253,21 @@ let rule_to_exception_graph (scope : Desugared.Ast.scope) = function
was provided." was provided."
| _ -> ()); | _ -> ());
let exc_graph = def_to_exception_graph def_key def in 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) exc_graph, sub_scope_var, var_pos)
sub_scope_vars_redefs_candidates sub_scope_vars_redefs_candidates
in in
List.fold_left List.fold_left
(fun exc_graphs (new_exc_graph, subscope_var, var_pos) -> (fun exc_graphs (new_exc_graph, subscope_var, var_pos) ->
Desugared.Ast.ScopeDef.Map.add D.ScopeDef.Map.add
(Desugared.Ast.ScopeDef.SubScopeVar (D.ScopeDef.SubScopeVar (sub_scope_index, subscope_var, var_pos))
(sub_scope_index, subscope_var, var_pos))
new_exc_graph exc_graphs) new_exc_graph exc_graphs)
Desugared.Ast.ScopeDef.Map.empty D.ScopeDef.Map.empty
(Desugared.Ast.ScopeDef.Map.values sub_scope_vars_redefs) (D.ScopeDef.Map.values sub_scope_vars_redefs)
| Assertion _ -> | Assertion _ -> D.ScopeDef.Map.empty (* no exceptions for assertions *)
Desugared.Ast.ScopeDef.Map.empty (* no exceptions for assertions *)
let scope_to_exception_graphs (scope : Desugared.Ast.scope) : let scope_to_exception_graphs (scope : D.scope) :
Desugared.Dependency.ExceptionsDependencies.t Desugared.Ast.ScopeDef.Map.t = Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t =
let scope_dependencies = let scope_dependencies =
Desugared.Dependency.build_scope_dependencies scope Desugared.Dependency.build_scope_dependencies scope
in in
@ -272,25 +278,25 @@ let scope_to_exception_graphs (scope : Desugared.Ast.scope) :
List.fold_left List.fold_left
(fun exceptions_graphs scope_def_key -> (fun exceptions_graphs scope_def_key ->
let new_exceptions_graphs = rule_to_exception_graph scope scope_def_key in 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 *)) (fun _ _ _ -> assert false (* there should not be key conflicts *))
new_exceptions_graphs exceptions_graphs) 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) : let build_exceptions_graph (pgrm : D.program) :
Desugared.Dependency.ExceptionsDependencies.t Desugared.Ast.ScopeDef.Map.t = Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t =
ScopeName.Map.fold ScopeName.Map.fold
(fun _ scope exceptions_graph -> (fun _ scope exceptions_graph ->
let new_exceptions_graphs = scope_to_exception_graphs scope in 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*)) (fun _ _ _ -> assert false (* key conflicts should not happen*))
new_exceptions_graphs exceptions_graph) 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 (** Transforms a flat list of rules into a tree, taking into account the
priorities declared between rules *) priorities declared between rules *)
let def_map_to_tree 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 (exc_graph : Desugared.Dependency.ExceptionsDependencies.t) : rule_tree list
= =
(* we start by the base cases: they are the vertices which have no (* 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) ~(is_reentrant_var : bool)
(ctx : ctx) (ctx : ctx)
(def_pos : Pos.t) (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 = (tree : rule_tree) : untyped Ast.expr boxed =
let emark = Untyped { pos = def_pos } in let emark = Untyped { pos = def_pos } in
let exceptions, base_rules = 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 (* 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 the whole rule tree into a function, we need to perform some alpha-renaming
of all the expressions *) of all the expressions *)
let substitute_parameter let substitute_parameter (e : D.expr boxed) (rule : D.rule) : D.expr boxed =
(e : Desugared.Ast.expr boxed) match params, rule.D.rule_parameter with
(rule : Desugared.Ast.rule) : Desugared.Ast.expr boxed =
match params, rule.Desugared.Ast.rule_parameter with
| Some new_params, Some (old_params_with_types, _) -> | Some new_params, Some (old_params_with_types, _) ->
let old_params, _ = List.split old_params_with_types in let old_params, _ = List.split old_params_with_types in
let old_params = Array.of_list (List.map Mark.remove old_params) 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) ctx)
in in
let base_just_list = let base_just_list =
List.map List.map (fun rule -> substitute_parameter rule.D.rule_just rule) base_rules
(fun rule -> substitute_parameter rule.Desugared.Ast.rule_just rule)
base_rules
in in
let base_cons_list = let base_cons_list =
List.map List.map (fun rule -> substitute_parameter rule.D.rule_cons rule) base_rules
(fun rule -> substitute_parameter rule.Desugared.Ast.rule_cons rule)
base_rules
in 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 = untyped Ast.expr boxed list =
List.map List.map
(fun e -> (fun e ->
@ -419,7 +419,7 @@ let rec rule_tree_to_expr
(Expr.elit (LBool true) emark) (Expr.elit (LBool true) emark)
default_containing_base_cases emark default_containing_base_cases emark
in 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 | None, None -> default
| Some new_params, Some (ls, _) -> | Some new_params, Some (ls, _) ->
let _, tys = List.split ls in let _, tys = List.split ls in
@ -449,34 +449,27 @@ let translate_def
~(is_cond : bool) ~(is_cond : bool)
~(is_subscope_var : bool) ~(is_subscope_var : bool)
(ctx : ctx) (ctx : ctx)
(def_info : Desugared.Ast.ScopeDef.t) (def_info : D.ScopeDef.t)
(def : Desugared.Ast.rule RuleName.Map.t) (def : D.rule RuleName.Map.t)
(params : (Uid.MarkedString.info * typ) list Mark.pos option) (params : (Uid.MarkedString.info * typ) list Mark.pos option)
(typ : typ) (typ : typ)
(io : Desugared.Ast.io) (io : D.io)
(exc_graph : Desugared.Dependency.ExceptionsDependencies.t) : (exc_graph : Desugared.Dependency.ExceptionsDependencies.t) :
untyped Ast.expr boxed = untyped Ast.expr boxed =
(* Here, we have to transform this list of rules into a default tree. *) (* 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 top_list = def_map_to_tree def exc_graph in
let is_input = let is_input =
match Mark.remove io.Desugared.Ast.io_input with match Mark.remove io.D.io_input with OnlyInput -> true | _ -> false
| OnlyInput -> true
| _ -> false
in in
let is_reentrant = let is_reentrant =
match Mark.remove io.Desugared.Ast.io_input with match Mark.remove io.D.io_input with Reentrant -> true | _ -> false
| Reentrant -> true
| _ -> false
in 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 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 (* 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 the condition is declared. Except when the variable is an input,
where we want the [false] to be added at each caller parent scope. *) where we want the [false] to be added at each caller parent scope. *)
Some Some (D.always_false_rule (D.ScopeDef.get_position def_info) params)
(Desugared.Ast.always_false_rule
(Desugared.Ast.ScopeDef.get_position def_info)
params)
else None else None
in in
if if
@ -505,7 +498,7 @@ let translate_def
will not be provided by the calee scope, it has to be placed in the will not be provided by the calee scope, it has to be placed in the
caller. *) caller. *)
then 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 let empty_error = Expr.eemptyerror m in
match params with match params with
| Some (ps, _) -> | Some (ps, _) ->
@ -517,7 +510,7 @@ let translate_def
| _ -> empty_error | _ -> empty_error
else else
rule_tree_to_expr ~toplevel:true ~is_reentrant_var:is_reentrant ctx 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 (Option.map
(fun (ps, _) -> (fun (ps, _) ->
(List.map (fun (lbl, _) -> Var.make (Mark.remove lbl))) ps) (List.map (fun (lbl, _) -> Var.make (Mark.remove lbl))) ps)
@ -526,7 +519,7 @@ let translate_def
| [], None -> | [], None ->
(* In this case, there are no rules to define the expression and no (* In this case, there are no rules to define the expression and no
default value so we put an empty rule. *) 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 -> | [], Some top_value ->
(* In this case, there are no rules to define the expression but a (* In this case, there are no rules to define the expression but a
default value so we put it. *) default value so we put it. *)
@ -536,36 +529,32 @@ let translate_def
exceptions to the default value *) exceptions to the default value *)
Node (top_list, [top_value]) Node (top_list, [top_value])
| [top_tree], None -> top_tree | [top_tree], None -> top_tree
| _, None -> | _, None -> Node (top_list, [D.empty_rule (Mark.get typ) params]))
Node (top_list, [Desugared.Ast.empty_rule (Mark.get typ) params]))
let translate_rule let translate_rule
ctx ctx
(scope : Desugared.Ast.scope) (scope : D.scope)
(exc_graphs : (exc_graphs :
Desugared.Dependency.ExceptionsDependencies.t Desugared.Ast.ScopeDef.Map.t) Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t) = function
= function
| Desugared.Dependency.Vertex.Var (var, state) -> ( | Desugared.Dependency.Vertex.Var (var, state) -> (
let scope_def = let scope_def =
Desugared.Ast.ScopeDef.Map.find D.ScopeDef.Map.find (D.ScopeDef.Var (var, state)) scope.scope_defs
(Desugared.Ast.ScopeDef.Var (var, state))
scope.scope_defs
in in
let var_def = scope_def.D.scope_def_rules in let var_def = scope_def.D.scope_def_rules in
let var_params = scope_def.D.scope_def_parameters in let var_params = scope_def.D.scope_def_parameters in
let var_typ = scope_def.D.scope_def_typ in let var_typ = scope_def.D.scope_def_typ in
let is_cond = scope_def.D.scope_def_is_condition 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) -> | OnlyInput when not (RuleName.Map.is_empty var_def) ->
assert false (* error already raised *) assert false (* error already raised *)
| OnlyInput -> [] | OnlyInput -> []
(* we do not provide any definition for an input-only variable *) (* 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 = let expr_def =
translate_def ctx scope_def_key var_def var_params var_typ translate_def ctx scope_def_key var_def var_params var_typ
scope_def.Desugared.Ast.scope_def_io scope_def.D.scope_def_io
(Desugared.Ast.ScopeDef.Map.find scope_def_key exc_graphs) (D.ScopeDef.Map.find scope_def_key exc_graphs)
~is_cond ~is_subscope_var:false ~is_cond ~is_subscope_var:false
in in
let scope_var = let scope_var =
@ -577,10 +566,10 @@ let translate_rule
[ [
Ast.Definition Ast.Definition
( ( ScopelangScopeVar ( ( 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) ), Mark.get (ScopeVar.get_info scope_var) ),
var_typ, var_typ,
scope_def.Desugared.Ast.scope_def_io, scope_def.D.scope_def_io,
Expr.unbox expr_def ); Expr.unbox expr_def );
]) ])
| Desugared.Dependency.Vertex.SubScope sub_scope_index -> | Desugared.Dependency.Vertex.SubScope sub_scope_index ->
@ -590,38 +579,34 @@ let translate_rule
SubScopeName.Map.find sub_scope_index scope.scope_sub_scopes SubScopeName.Map.find sub_scope_index scope.scope_sub_scopes
in in
let sub_scope_vars_redefs_candidates = let sub_scope_vars_redefs_candidates =
Desugared.Ast.ScopeDef.Map.filter D.ScopeDef.Map.filter
(fun def_key scope_def -> (fun def_key scope_def ->
match def_key with match def_key with
| Desugared.Ast.ScopeDef.Var _ -> false | D.ScopeDef.Var _ -> false
| Desugared.Ast.ScopeDef.SubScopeVar (sub_scope_index', _, _) -> | D.ScopeDef.SubScopeVar (sub_scope_index', _, _) ->
sub_scope_index = sub_scope_index' sub_scope_index = sub_scope_index'
(* We exclude subscope variables that have 0 re-definitions and are (* We exclude subscope variables that have 0 re-definitions and are
not visible in the input of the subscope *) not visible in the input of the subscope *)
&& not && not
((match ((match Mark.remove scope_def.D.scope_def_io.io_input with
Mark.remove scope_def.Desugared.Ast.scope_def_io.io_input
with
| NoInput -> true | NoInput -> true
| _ -> false) | _ -> false)
&& RuleName.Map.is_empty scope_def.scope_def_rules)) && RuleName.Map.is_empty scope_def.scope_def_rules))
scope.scope_defs scope.scope_defs
in in
let sub_scope_vars_redefs = let sub_scope_vars_redefs =
Desugared.Ast.ScopeDef.Map.mapi D.ScopeDef.Map.mapi
(fun def_key scope_def -> (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 def_typ = scope_def.scope_def_typ in
let is_cond = scope_def.scope_def_is_condition in let is_cond = scope_def.scope_def_is_condition in
match def_key with match def_key with
| Desugared.Ast.ScopeDef.Var _ -> assert false (* should not happen *) | D.ScopeDef.Var _ -> assert false (* should not happen *)
| Desugared.Ast.ScopeDef.SubScopeVar (_, sub_scope_var, var_pos) -> | D.ScopeDef.SubScopeVar (_, sub_scope_var, var_pos) ->
(* This definition redefines a variable of the correct subscope. But (* This definition redefines a variable of the correct subscope. But
we have to check that this redefinition is allowed with respect we have to check that this redefinition is allowed with respect
to the io parameters of that subscope variable. *) to the io parameters of that subscope variable. *)
(match (match Mark.remove scope_def.D.scope_def_io.io_input with
Mark.remove scope_def.Desugared.Ast.scope_def_io.io_input
with
| NoInput -> assert false (* error already raised *) | NoInput -> assert false (* error already raised *)
| OnlyInput when RuleName.Map.is_empty def && not is_cond -> | OnlyInput when RuleName.Map.is_empty def && not is_cond ->
assert false (* error already raised *) assert false (* error already raised *)
@ -630,8 +615,8 @@ let translate_rule
redefinition to a proper Scopelang term. *) redefinition to a proper Scopelang term. *)
let expr_def = let expr_def =
translate_def ctx def_key def scope_def.D.scope_def_parameters translate_def ctx def_key def scope_def.D.scope_def_parameters
def_typ scope_def.Desugared.Ast.scope_def_io def_typ scope_def.D.scope_def_io
(Desugared.Ast.ScopeDef.Map.find def_key exc_graphs) (D.ScopeDef.Map.find def_key exc_graphs)
~is_cond ~is_subscope_var:true ~is_cond ~is_subscope_var:true
in in
let subscop_real_name = let subscop_real_name =
@ -639,25 +624,26 @@ let translate_rule
in in
Ast.Definition Ast.Definition
( ( SubScopeVar ( ( SubScopeVar
( subscop_real_name, {
(sub_scope_index, var_pos), scope = subscop_real_name;
match alias = sub_scope_index, var_pos;
ScopeVar.Map.find sub_scope_var ctx.scope_var_mapping var =
with (match
| WholeVar v -> v, var_pos ScopeVar.Map.find sub_scope_var ctx.scope_var_mapping
| States states -> with
(* When defining a sub-scope variable, we always define | WholeVar v -> v, var_pos
its first state in the sub-scope. *) | States states ->
snd (List.hd states), var_pos ), (* When defining a sub-scope variable, we always
define its first state in the sub-scope. *)
snd (List.hd states), var_pos);
},
var_pos ), var_pos ),
def_typ, def_typ,
scope_def.Desugared.Ast.scope_def_io, scope_def.D.scope_def_io,
Expr.unbox expr_def )) Expr.unbox expr_def ))
sub_scope_vars_redefs_candidates sub_scope_vars_redefs_candidates
in in
let sub_scope_vars_redefs = let sub_scope_vars_redefs = D.ScopeDef.Map.values sub_scope_vars_redefs in
Desugared.Ast.ScopeDef.Map.values sub_scope_vars_redefs
in
sub_scope_vars_redefs sub_scope_vars_redefs
@ [ @ [
Ast.Call Ast.Call
@ -668,43 +654,21 @@ let translate_rule
] ]
| Assertion a_name -> | Assertion a_name ->
let assertion_expr = let assertion_expr =
Desugared.Ast.AssertionName.Map.find a_name scope.scope_assertions D.AssertionName.Map.find a_name scope.scope_assertions
in in
(* we unbox here because assertions do not have free variables (at this (* we unbox here because assertions do not have free variables (at this
point Bindlib variables are only for fuhnction parameters)*) point Bindlib variables are only for fuhnction parameters)*)
let assertion_expr = translate_expr ctx (Expr.unbox assertion_expr) in let assertion_expr = translate_expr ctx (Expr.unbox assertion_expr) in
[Ast.Assertion (Expr.unbox assertion_expr)] [Ast.Assertion (Expr.unbox assertion_expr)]
(** Translates a scope *) let translate_scope_interface ctx 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 scope_sig = let scope_sig =
ScopeVar.Map.fold ScopeVar.Map.fold
(fun var (states : Desugared.Ast.var_or_states) acc -> (fun var (states : D.var_or_states) acc ->
match states with match states with
| WholeVar -> | WholeVar ->
let scope_def = let scope_def =
Desugared.Ast.ScopeDef.Map.find D.ScopeDef.Map.find (D.ScopeDef.Var (var, None)) scope.D.scope_defs
(Desugared.Ast.ScopeDef.Var (var, None))
scope.scope_defs
in in
let typ = scope_def.scope_def_typ in let typ = scope_def.scope_def_typ in
ScopeVar.Map.add ScopeVar.Map.add
@ -720,9 +684,9 @@ let translate_scope
List.fold_left List.fold_left
(fun acc (state : StateName.t) -> (fun acc (state : StateName.t) ->
let scope_def = let scope_def =
Desugared.Ast.ScopeDef.Map.find D.ScopeDef.Map.find
(Desugared.Ast.ScopeDef.Var (var, Some state)) (D.ScopeDef.Var (var, Some state))
scope.scope_defs scope.D.scope_defs
in in
ScopeVar.Map.add ScopeVar.Map.add
(match ScopeVar.Map.find var ctx.scope_var_mapping with (match ScopeVar.Map.find var ctx.scope_var_mapping with
@ -734,36 +698,59 @@ let translate_scope
scope.scope_vars ScopeVar.Map.empty scope.scope_vars ScopeVar.Map.empty
in in
let pos = Mark.get (ScopeName.get_info scope.scope_uid) in let pos = Mark.get (ScopeName.get_info scope.scope_uid) in
{ Mark.add pos
Ast.scope_decl_name = scope.scope_uid; {
Ast.scope_decl_rules; Ast.scope_decl_name = scope.scope_uid;
Ast.scope_sig; Ast.scope_decl_rules = [];
Ast.scope_mark = Untyped { pos }; Ast.scope_sig;
Ast.scope_options = scope.scope_options; 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} *) (** {1 API} *)
let translate_program let translate_program
(pgrm : Desugared.Ast.program) (desugared : D.program)
(exc_graphs : (exc_graphs :
Desugared.Dependency.ExceptionsDependencies.t Desugared.Ast.ScopeDef.Map.t) Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t) :
: untyped Ast.program = untyped Ast.program =
(* First we give mappings to all the locations between Desugared and This (* First we give mappings to all the locations between Desugared and This
involves creating a new Scopelang scope variable for every state of a involves creating a new Scopelang scope variable for every state of a
Desugared variable. *) 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 (* 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 *) have different types for Desugared.ScopeVar.t and Scopelang.ScopeVar.t *)
ScopeName.Map.fold ScopeName.Map.fold
(fun _scope scope_decl ctx -> (fun _scope scope_decl ctx ->
ScopeVar.Map.fold 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 var_name, var_pos = ScopeVar.get_info scope_var in
let new_var = let new_var =
match states with match states with
| Desugared.Ast.WholeVar -> | D.WholeVar -> WholeVar (ScopeVar.fresh (var_name, var_pos))
WholeVar (ScopeVar.fresh (var_name, var_pos))
| States states -> | States states ->
let var_prefix = var_name ^ "_" in let var_prefix = var_name ^ "_" in
let state_var state = let state_var state =
@ -777,38 +764,78 @@ let translate_program
scope_var_mapping = scope_var_mapping =
ScopeVar.Map.add scope_var new_var ctx.scope_var_mapping; ScopeVar.Map.add scope_var new_var ctx.scope_var_mapping;
}) })
scope_decl.Desugared.Ast.scope_vars ctx) scope_decl.D.scope_vars ctx)
pgrm.Desugared.Ast.program_scopes desugared.D.program_scopes
{ {
scope_var_mapping = ScopeVar.Map.empty; scope_var_mapping = ScopeVar.Map.empty;
var_mapping = Var.Map.empty; var_mapping = Var.Map.empty;
decl_ctx = pgrm.program_ctx; decl_ctx = desugared.program_ctx;
modules;
} }
in in
let ctx_scopes = let ctx = make_ctx desugared in
ScopeName.Map.map let rec gather_scope_vars acc modules =
(fun out_str -> ModuleName.Map.fold
let out_struct_fields = (fun _modname mctx acc ->
ScopeVar.Map.fold let acc = gather_scope_vars acc mctx.modules in
(fun var fld out_map -> ScopeVar.Map.union (fun _ _ -> assert false) acc mctx.scope_var_mapping)
let var' = modules acc
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
in in
let program_scopes = let ctx =
ScopeName.Map.fold {
(fun scope_name scope new_program_scopes -> ctx with
let new_program_scope = translate_scope ctx scope exc_graphs in scope_var_mapping = gather_scope_vars ctx.scope_var_mapping ctx.modules;
ScopeName.Map.add scope_name new_program_scope new_program_scopes) }
pgrm.program_scopes ScopeName.Map.empty
in 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 = let program_topdefs =
TopdefName.Map.mapi TopdefName.Map.mapi
(fun id -> function (fun id -> function
@ -816,10 +843,16 @@ let translate_program
| None, (_, pos) -> | None, (_, pos) ->
Message.raise_spanned_error pos "No definition found for %a" Message.raise_spanned_error pos "No definition found for %a"
TopdefName.format id) 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 in
{ {
Ast.program_topdefs; Ast.program_topdefs;
program_scopes; Ast.program_scopes;
program_ctx = { pgrm.program_ctx with ctx_scopes }; Ast.program_ctx;
Ast.program_modules;
} }

4
compiler/scopelang/print.ml
View File

@ -48,7 +48,7 @@ let enum
(Print.typ ctx) typ)) (Print.typ ctx) typ))
(EnumConstructor.Map.bindings cases) (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@]" Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@]@\n@[<v 2> %a@]"
Print.keyword "let" Print.keyword "scope" ScopeName.format name Print.keyword "let" Print.keyword "scope" ScopeName.format name
(Format.pp_print_list ~pp_sep:Format.pp_print_space (Format.pp_print_list ~pp_sep:Format.pp_print_space
@ -78,7 +78,7 @@ let scope ?debug ctx fmt (name, decl) =
(fun fmt e -> (fun fmt e ->
match Mark.remove loc with match Mark.remove loc with
| SubScopeVar _ | ToplevelVar _ -> Print.expr () fmt e | SubScopeVar _ | ToplevelVar _ -> Print.expr () fmt e
| ScopelangScopeVar v -> ( | ScopelangScopeVar { name = v } -> (
match match
Mark.remove Mark.remove
(snd (ScopeVar.Map.find (Mark.remove v) decl.scope_sig)) (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 License for the specific language governing permissions and limitations under
the License. *) the License. *)
open Catala_utils
val scope : val scope :
?debug:bool (** [true] for debug printing *) -> ?debug:bool (** [true] for debug printing *) ->
Shared_ast.decl_ctx -> Shared_ast.decl_ctx ->
Format.formatter -> Format.formatter ->
Shared_ast.ScopeName.t * 'm Ast.scope_decl -> Shared_ast.ScopeName.t * 'm Ast.scope_decl Mark.pos ->
unit unit
val program : val program :

55
compiler/shared_ast/definitions.ml
View File

@ -22,11 +22,12 @@
open Catala_utils open Catala_utils
module Runtime = Runtime_ocaml.Runtime module Runtime = Runtime_ocaml.Runtime
module ScopeName = Uid.Gen () module ModuleName = Uid.Module
module TopdefName = Uid.Gen () module ScopeName = Uid.Gen_qualified ()
module StructName = Uid.Gen () module TopdefName = Uid.Gen_qualified ()
module StructName = Uid.Gen_qualified ()
module StructField = Uid.Gen () module StructField = Uid.Gen ()
module EnumName = Uid.Gen () module EnumName = Uid.Gen_qualified ()
module EnumConstructor = Uid.Gen () module EnumConstructor = Uid.Gen ()
(** Only used by surface *) (** Only used by surface *)
@ -312,6 +313,10 @@ type untyped = { pos : Pos.t } [@@caml.unboxed]
type typed = { pos : Pos.t; ty : typ } type typed = { pos : Pos.t; ty : typ }
type 'a custom = { pos : Pos.t; custom : 'a } 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 (** The generic type of AST markings. Using a GADT allows functions to be
polymorphic in the marking, but still do transformations on types when polymorphic in the marking, but still do transformations on types when
appropriate. The [Custom] case can be used within passes that need to store appropriate. The [Custom] case can be used within passes that need to store
@ -339,19 +344,32 @@ type lit =
| LDate of date | LDate of date
| LDuration of duration | 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] *) (** Locations are handled differently in [desugared] and [scopelang] *)
type 'a glocation = type 'a glocation =
| DesugaredScopeVar : | DesugaredScopeVar : {
ScopeVar.t Mark.pos * StateName.t option name : ScopeVar.t Mark.pos;
state : StateName.t option;
}
-> < scopeVarStates : yes ; .. > glocation -> < scopeVarStates : yes ; .. > glocation
| ScopelangScopeVar : | ScopelangScopeVar : {
ScopeVar.t Mark.pos name : ScopeVar.t Mark.pos;
}
-> < scopeVarSimpl : yes ; .. > glocation -> < scopeVarSimpl : yes ; .. > glocation
| SubScopeVar : | SubScopeVar : {
ScopeName.t * SubScopeName.t Mark.pos * ScopeVar.t Mark.pos scope : ScopeName.t;
alias : SubScopeName.t Mark.pos;
var : ScopeVar.t Mark.pos;
}
-> < explicitScopes : yes ; .. > glocation -> < explicitScopes : yes ; .. > glocation
| ToplevelVar : | ToplevelVar : {
TopdefName.t Mark.pos name : TopdefName.t Mark.pos;
}
-> < explicitScopes : yes ; .. > glocation -> < explicitScopes : yes ; .. > glocation
type ('a, 'm) gexpr = (('a, 'm) naked_gexpr, 'm) marked 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 -> ('a, (< .. > as 'b), 'm) base_gexpr
| EArray : ('a, 'm) gexpr list -> ('a, < .. >, 'm) base_gexpr | EArray : ('a, 'm) gexpr list -> ('a, < .. >, 'm) base_gexpr
| EVar : ('a, 'm) naked_gexpr Bindlib.var -> ('a, _, 'm) base_gexpr | EVar : ('a, 'm) naked_gexpr Bindlib.var -> ('a, _, 'm) base_gexpr
| EExternal : Qident.t -> ('a, < .. >, 't) base_gexpr
| EAbs : { | EAbs : {
binder : (('a, 'a, 'm) base_gexpr, ('a, 'm) gexpr) Bindlib.mbinder; binder : (('a, 'a, 'm) base_gexpr, ('a, 'm) gexpr) Bindlib.mbinder;
tys : typ list; tys : typ list;
@ -450,6 +467,10 @@ and ('a, 'b, 'm) base_gexpr =
-> ('a, < resolvedNames : yes ; .. >, 'm) base_gexpr -> ('a, < resolvedNames : yes ; .. >, 'm) base_gexpr
(** Resolved struct/enums, after [desugared] *) (** Resolved struct/enums, after [desugared] *)
(* Lambda-like *) (* Lambda-like *)
| EExternal : {
name : external_ref Mark.pos;
}
-> ('a, < explicitScopes : no ; .. >, 't) base_gexpr
| EAssert : ('a, 'm) gexpr -> ('a, < assertions : yes ; .. >, 'm) base_gexpr | EAssert : ('a, 'm) gexpr -> ('a, < assertions : yes ; .. >, 'm) base_gexpr
(* Default terms *) (* Default terms *)
| EDefault : { | EDefault : {
@ -565,7 +586,8 @@ type 'e code_item_list =
type struct_ctx = typ StructField.Map.t StructName.Map.t type struct_ctx = typ StructField.Map.t StructName.Map.t
type enum_ctx = typ EnumConstructor.Map.t EnumName.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_name : StructName.t;
out_struct_fields : StructField.t ScopeVar.Map.t; out_struct_fields : StructField.t ScopeVar.Map.t;
} }
@ -575,8 +597,9 @@ type decl_ctx = {
ctx_structs : struct_ctx; ctx_structs : struct_ctx;
ctx_struct_fields : StructField.t StructName.Map.t Ident.Map.t; ctx_struct_fields : StructField.t StructName.Map.t Ident.Map.t;
(** needed for disambiguation (desugared -> scope) *) (** needed for disambiguation (desugared -> scope) *)
ctx_scopes : scope_out_struct ScopeName.Map.t; ctx_scopes : scope_info ScopeName.Map.t;
ctx_modules : typ Qident.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 } 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)) Bindlib.msubst binder (Array.of_list (List.map Mark.remove vars))
let evar v mark = Mark.add mark (Bindlib.box_var v) 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 etuple args = Box.appn args @@ fun args -> ETuple args
let etupleaccess e index size = let etupleaccess e index size =
@ -146,28 +146,28 @@ let ecustom obj targs tret mark =
let elocation loc = Box.app0 @@ ELocation loc 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 Mark.add mark
@@ Bindlib.box_apply @@ Bindlib.box_apply
(fun fields -> EStruct { name; fields }) (fun fields -> EStruct { name; fields })
(Box.lift_struct (StructField.Map.map Box.lift fields)) (Box.lift_struct (StructField.Map.map Box.lift fields))
let edstructaccess e field name_opt = let edstructaccess ~name_opt ~field ~e =
Box.app1 e @@ fun e -> EDStructAccess { name_opt; e; field } Box.app1 e @@ fun e -> EDStructAccess { name_opt; field; e }
let estructaccess e field name = let estructaccess ~name ~field ~e =
Box.app1 e @@ fun e -> EStructAccess { name; e; field } 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 Mark.add mark
@@ Bindlib.box_apply2 @@ Bindlib.box_apply2
(fun e cases -> EMatch { name; e; cases }) (fun e cases -> EMatch { name; e; cases })
(Box.lift e) (Box.lift e)
(Box.lift_enum (EnumConstructor.Map.map Box.lift cases)) (Box.lift_enum (EnumConstructor.Map.map Box.lift cases))
let escopecall scope args mark = let escopecall ~scope ~args mark =
Mark.add mark Mark.add mark
@@ Bindlib.box_apply @@ Bindlib.box_apply
(fun args -> EScopeCall { scope; args }) (fun args -> EScopeCall { scope; args })
@ -250,7 +250,7 @@ let maybe_ty (type m) ?(typ = TAny) (m : m mark) : typ =
(* - Predefined types (option) - *) (* - 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 none_constr = EnumConstructor.fresh ("ENone", Pos.no_pos)
let some_constr = EnumConstructor.fresh ("ESome", 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 | EOp { op; tys } -> eop op tys m
| EArray args -> earray (List.map f args) m | EArray args -> earray (List.map f args) m
| EVar v -> evar (Var.translate v) m | EVar v -> evar (Var.translate v) m
| EExternal eref -> eexternal eref m | EExternal { name } -> eexternal ~name m
| EAbs { binder; tys } -> | EAbs { binder; tys } ->
let vars, body = Bindlib.unmbind binder in let vars, body = Bindlib.unmbind binder in
let body = f body in let body = f body in
@ -282,7 +282,7 @@ let map
eifthenelse (f cond) (f etrue) (f efalse) m eifthenelse (f cond) (f etrue) (f efalse) m
| ETuple args -> etuple (List.map f args) m | ETuple args -> etuple (List.map f args) m
| ETupleAccess { e; index; size } -> etupleaccess (f e) index size 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 | EAssert e1 -> eassert (f e1) m
| EDefault { excepts; just; cons } -> | EDefault { excepts; just; cons } ->
edefault (List.map f excepts) (f just) (f cons) m edefault (List.map f excepts) (f just) (f cons) m
@ -293,16 +293,16 @@ let map
| ELocation loc -> elocation loc m | ELocation loc -> elocation loc m
| EStruct { name; fields } -> | EStruct { name; fields } ->
let fields = StructField.Map.map f fields in let fields = StructField.Map.map f fields in
estruct name fields m estruct ~name ~fields m
| EDStructAccess { e; field; name_opt } -> | EDStructAccess { name_opt; field; e } ->
edstructaccess (f e) field name_opt m edstructaccess ~name_opt ~field ~e:(f e) m
| EStructAccess { e; field; name } -> estructaccess (f e) field name m | EStructAccess { name; field; e } -> estructaccess ~name ~field ~e:(f e) m
| EMatch { e; name; cases } -> | EMatch { name; e; cases } ->
let cases = EnumConstructor.Map.map f cases in let cases = EnumConstructor.Map.map f cases in
ematch (f e) name cases m ematch ~name ~e:(f e) ~cases m
| EScopeCall { scope; args } -> | EScopeCall { scope; args } ->
let fields = ScopeVar.Map.map f args in let args = ScopeVar.Map.map f args in
escopecall scope fields m escopecall ~scope ~args m
| ECustom { obj; targs; tret } -> ecustom obj targs tret 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) 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 let acc, args = lfoldmap args in
acc, earray args m acc, earray args m
| EVar v -> acc, evar (Var.translate v) m | EVar v -> acc, evar (Var.translate v) m
| EExternal eref -> acc, eexternal eref m | EExternal { name } -> acc, eexternal ~name m
| EAbs { binder; tys } -> | EAbs { binder; tys } ->
let vars, body = Bindlib.unmbind binder in let vars, body = Bindlib.unmbind binder in
let acc, body = f body in let acc, body = f body in
@ -386,9 +386,9 @@ let map_gather
| ETupleAccess { e; index; size } -> | ETupleAccess { e; index; size } ->
let acc, e = f e in let acc, e = f e in
acc, etupleaccess e index size m acc, etupleaccess e index size m
| EInj { e; name; cons } -> | EInj { name; cons; e } ->
let acc, e = f e in let acc, e = f e in
acc, einj e cons name m acc, einj ~name ~cons ~e m
| EAssert e -> | EAssert e ->
let acc, e = f e in let acc, e = f e in
acc, eassert e m acc, eassert e m
@ -416,14 +416,14 @@ let map_gather
fields fields
(acc, StructField.Map.empty) (acc, StructField.Map.empty)
in in
acc, estruct name fields m acc, estruct ~name ~fields m
| EDStructAccess { e; field; name_opt } -> | EDStructAccess { name_opt; field; e } ->
let acc, e = f e in let acc, e = f e in
acc, edstructaccess e field name_opt m acc, edstructaccess ~name_opt ~field ~e m
| EStructAccess { e; field; name } -> | EStructAccess { name; field; e } ->
let acc, e = f e in let acc, e = f e in
acc, estructaccess e field name m acc, estructaccess ~name ~field ~e m
| EMatch { e; name; cases } -> | EMatch { name; e; cases } ->
let acc, e = f e in let acc, e = f e in
let acc, cases = let acc, cases =
EnumConstructor.Map.fold EnumConstructor.Map.fold
@ -433,7 +433,7 @@ let map_gather
cases cases
(acc, EnumConstructor.Map.empty) (acc, EnumConstructor.Map.empty)
in in
acc, ematch e name cases m acc, ematch ~name ~e ~cases m
| EScopeCall { scope; args } -> | EScopeCall { scope; args } ->
let acc, args = let acc, args =
ScopeVar.Map.fold ScopeVar.Map.fold
@ -442,7 +442,7 @@ let map_gather
join acc acc1, ScopeVar.Map.add var e args) join acc acc1, ScopeVar.Map.add var e args)
args (acc, ScopeVar.Map.empty) args (acc, ScopeVar.Map.empty)
in in
acc, escopecall scope args m acc, escopecall ~scope ~args m
| ECustom { obj; targs; tret } -> acc, ecustom obj targs tret m | ECustom { obj; targs; tret } -> acc, ecustom obj targs tret m
(* - *) (* - *)
@ -520,20 +520,25 @@ let compare_location
(x : a glocation Mark.pos) (x : a glocation Mark.pos)
(y : a glocation Mark.pos) = (y : a glocation Mark.pos) =
match Mark.remove x, Mark.remove y with match Mark.remove x, Mark.remove y with
| DesugaredScopeVar (vx, None), DesugaredScopeVar (vy, None) | ( DesugaredScopeVar { name = vx; state = None },
| DesugaredScopeVar (vx, Some _), DesugaredScopeVar (vy, None) DesugaredScopeVar { name = vy; state = None } )
| DesugaredScopeVar (vx, None), DesugaredScopeVar (vy, Some _) -> | ( 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) 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 let cmp = ScopeVar.compare x y in
if cmp = 0 then StateName.compare sx sy else cmp if cmp = 0 then StateName.compare sx sy else cmp
| ScopelangScopeVar (vx, _), ScopelangScopeVar (vy, _) -> | ScopelangScopeVar { name = vx, _ }, ScopelangScopeVar { name = vy, _ } ->
ScopeVar.compare vx vy ScopeVar.compare vx vy
| ( SubScopeVar (_, (xsubindex, _), (xsubvar, _)), | ( SubScopeVar { alias = xsubindex, _; var = xsubvar, _; _ },
SubScopeVar (_, (ysubindex, _), (ysubvar, _)) ) -> SubScopeVar { alias = ysubindex, _; var = ysubvar, _; _ } ) ->
let c = SubScopeName.compare xsubindex ysubindex in let c = SubScopeName.compare xsubindex ysubindex in
if c = 0 then ScopeVar.compare xsubvar ysubvar else c 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
| _, DesugaredScopeVar _ -> 1 | _, DesugaredScopeVar _ -> 1
| ScopelangScopeVar _, _ -> -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 equal_except ex1 ex2 = ex1 = ex2
let compare_except ex1 ex2 = Stdlib.compare 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 (* weird indentation; see
https://github.com/ocaml-ppx/ocamlformat/issues/2143 *) https://github.com/ocaml-ppx/ocamlformat/issues/2143 *)
let rec equal_list : 'a. ('a, 't) gexpr list -> ('a, 't) gexpr list -> bool = let rec equal_list : 'a. ('a, 't) gexpr list -> ('a, 't) gexpr list -> bool =
fun es1 es2 -> fun es1 es2 -> List.equal equal es1 es2
try List.for_all2 equal es1 es2 with Invalid_argument _ -> false
and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool = and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool =
fun e1 e2 -> fun e1 e2 ->
match Mark.remove e1, Mark.remove e2 with match Mark.remove e1, Mark.remove e2 with
| EVar v1, EVar v2 -> Bindlib.eq_vars v1 v2 | 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 | ETuple es1, ETuple es2 -> equal_list es1 es2
| ( ETupleAccess { e = e1; index = id1; size = s1 }, | ( ETupleAccess { e = e1; index = id1; size = s1 },
ETupleAccess { e = e2; index = id2; size = s2 } ) -> 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 List.compare compare a1 a2
| EVar v1, EVar v2 -> | EVar v1, EVar v2 ->
Bindlib.compare_vars v1 v2 Bindlib.compare_vars v1 v2
| EExternal eref1, EExternal eref2 -> | EExternal { name = n1 }, EExternal { name = n2 } ->
Qident.compare eref1 eref2 Mark.compare compare_external_ref n1 n2
| EAbs {binder=binder1; tys=typs1}, | EAbs {binder=binder1; tys=typs1},
EAbs {binder=binder2; tys=typs2} -> EAbs {binder=binder2; tys=typs2} ->
List.compare Type.compare typs1 typs2 @@< fun () -> List.compare Type.compare typs1 typs2 @@< fun () ->
@ -649,8 +669,8 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
compare e1 e2 compare e1 e2
| ELocation l1, ELocation l2 -> | ELocation l1, ELocation l2 ->
compare_location (Mark.add Pos.no_pos l1) (Mark.add Pos.no_pos l2) compare_location (Mark.add Pos.no_pos l1) (Mark.add Pos.no_pos l2)
| EStruct {name=name1; fields=field_map1}, | EStruct {name=name1; fields=field_map1 },
EStruct {name=name2; fields=field_map2} -> EStruct {name=name2; fields=field_map2 } ->
StructName.compare name1 name2 @@< fun () -> StructName.compare name1 name2 @@< fun () ->
StructField.Map.compare compare field_map1 field_map2 StructField.Map.compare compare field_map1 field_map2
| EDStructAccess {e=e1; field=field_name1; name_opt=struct_name1}, | 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 () -> compare e1 e2 @@< fun () ->
Ident.compare field_name1 field_name2 @@< fun () -> Ident.compare field_name1 field_name2 @@< fun () ->
Option.compare StructName.compare struct_name1 struct_name2 Option.compare StructName.compare struct_name1 struct_name2
| EStructAccess {e=e1; field=field_name1; name=struct_name1}, | EStructAccess {e=e1; field=field_name1; name=struct_name1 },
EStructAccess {e=e2; field=field_name2; name=struct_name2} -> EStructAccess {e=e2; field=field_name2; name=struct_name2 } ->
compare e1 e2 @@< fun () -> compare e1 e2 @@< fun () ->
StructField.compare field_name1 field_name2 @@< fun () -> StructField.compare field_name1 field_name2 @@< fun () ->
StructName.compare struct_name1 struct_name2 StructName.compare struct_name1 struct_name2
| EMatch {e=e1; name=name1; cases=emap1}, | EMatch {e=e1; name=name1; cases=emap1 },
EMatch {e=e2; name=name2; cases=emap2} -> EMatch {e=e2; name=name2; cases=emap2 } ->
EnumName.compare name1 name2 @@< fun () -> EnumName.compare name1 name2 @@< fun () ->
compare e1 e2 @@< fun () -> compare e1 e2 @@< fun () ->
EnumConstructor.Map.compare compare emap1 emap2 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 s1 s2 @@< fun () ->
Int.compare n1 n2 @@< fun () -> Int.compare n1 n2 @@< fun () ->
compare e1 e2 compare e1 e2
| EInj {e=e1; name=name1; cons=cons1}, | EInj {e=e1; name=name1; cons=cons1 },
EInj {e=e2; name=name2; cons=cons2} -> EInj {e=e2; name=name2; cons=cons2 } ->
EnumName.compare name1 name2 @@< fun () -> EnumName.compare name1 name2 @@< fun () ->
EnumConstructor.compare cons1 cons2 @@< fun () -> EnumConstructor.compare cons1 cons2 @@< fun () ->
compare e1 e2 compare e1 e2
@ -783,7 +803,7 @@ module DefaultBindlibCtxRename = struct
let get_suffix : string -> int -> ctxt -> int * ctxt = let get_suffix : string -> int -> ctxt -> int * ctxt =
fun name suffix 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 let suffix = if suffix > n then suffix else n + 1 in
suffix, String.Map.add name suffix ctxt suffix, String.Map.add name suffix ctxt
@ -803,7 +823,7 @@ module DefaultBindlibCtxRename = struct
try try
let n = String.Map.find prefix ctxt in let n = String.Map.find prefix ctxt in
if suffix <= n then ctxt else String.Map.add prefix suffix ctxt 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 end
let rename_vars 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 *) (** 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 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 : val bind :
('a, 'm) gexpr Var.t array -> ('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 elocation : 'a glocation -> 'm mark -> ((< .. > as 'a), 'm) boxed_gexpr
val estruct : val estruct :
StructName.t -> name:StructName.t ->
('a, 'm) boxed_gexpr StructField.Map.t -> fields:('a, 'm) boxed_gexpr StructField.Map.t ->
'm mark -> 'm mark ->
('a any, 'm) boxed_gexpr ('a any, 'm) boxed_gexpr
val edstructaccess : val edstructaccess :
('a, 'm) boxed_gexpr -> name_opt:StructName.t option ->
Ident.t -> field:Ident.t ->
StructName.t option -> e:('a, 'm) boxed_gexpr ->
'm mark -> 'm mark ->
((< syntacticNames : yes ; .. > as 'a), 'm) boxed_gexpr ((< syntacticNames : yes ; .. > as 'a), 'm) boxed_gexpr
val estructaccess : val estructaccess :
('a, 'm) boxed_gexpr -> name:StructName.t ->
StructField.t -> field:StructField.t ->
StructName.t -> e:('a, 'm) boxed_gexpr ->
'm mark -> 'm mark ->
((< resolvedNames : yes ; .. > as 'a), 'm) boxed_gexpr ((< resolvedNames : yes ; .. > as 'a), 'm) boxed_gexpr
val einj : val einj :
('a, 'm) boxed_gexpr -> name:EnumName.t ->
EnumConstructor.t -> cons:EnumConstructor.t ->
EnumName.t -> e:('a, 'm) boxed_gexpr ->
'm mark -> 'm mark ->
('a any, 'm) boxed_gexpr ('a any, 'm) boxed_gexpr
val ematch : val ematch :
('a, 'm) boxed_gexpr -> name:EnumName.t ->
EnumName.t -> e:('a, 'm) boxed_gexpr ->
('a, 'm) boxed_gexpr EnumConstructor.Map.t -> cases:('a, 'm) boxed_gexpr EnumConstructor.Map.t ->
'm mark -> 'm mark ->
('a any, 'm) boxed_gexpr ('a any, 'm) boxed_gexpr
val escopecall : val escopecall :
ScopeName.t -> scope:ScopeName.t ->
('a, 'm) boxed_gexpr ScopeVar.Map.t -> args:('a, 'm) boxed_gexpr ScopeVar.Map.t ->
'm mark -> 'm mark ->
((< explicitScopes : yes ; .. > as 'a), 'm) boxed_gexpr ((< 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 (* 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 always use the tag directly (ordered as declared in the constr map), and
the field 0 *) the field 0 *)
let cons_map = EnumName.Map.find name ctx.ctx_enums in
let cons, ty = let cons, ty =
List.nth 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) (Obj.tag o - Obj.first_non_constant_constructor_tag)
in in
let e = runtime_to_val eval_expr ctx m ty (Obj.field o 0) 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 |> Obj.repr
| TEnum name1, EInj { name; cons; e } -> | TEnum name1, EInj { name; cons; e } ->
assert (EnumName.equal name name1); assert (EnumName.equal name name1);
let cons_map = EnumName.Map.find name ctx.ctx_enums in
let rec find_tag n = function let rec find_tag n = function
| [] -> assert false | [] -> assert false
| (c, ty) :: _ when EnumConstructor.equal c cons -> n, ty | (c, ty) :: _ when EnumConstructor.equal c cons -> n, ty
@ -511,7 +513,7 @@ and val_to_runtime :
in in
let tag, ty = let tag, ty =
find_tag Obj.first_non_constant_constructor_tag find_tag Obj.first_non_constant_constructor_tag
(EnumConstructor.Map.bindings (EnumName.Map.find name ctx.ctx_enums)) (EnumConstructor.Map.bindings cons_map)
in in
let o = Obj.with_tag tag (Obj.repr (Some ())) in let o = Obj.with_tag tag (Obj.repr (Some ())) in
Obj.set_field o 0 (val_to_runtime eval_expr ctx ty e); 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 Message.raise_spanned_error pos
"free variable found at evaluation (should not happen if term was \ "free variable found at evaluation (should not happen if term was \
well-typed)" well-typed)"
| EExternal qid -> ( | EExternal { name } ->
match Qident.Map.find_opt qid ctx.ctx_modules with let path =
| None -> match Mark.remove name with
Message.raise_spanned_error pos "Reference to %a could not be resolved" | External_value td -> TopdefName.path td
Qident.format qid | External_scope s -> ScopeName.path s
| Some ty -> in
let o = Runtime.lookup_value qid in let ty =
runtime_to_val evaluate_expr ctx m ty o) 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 } -> ( | EApp { f = e1; args } -> (
let e1 = evaluate_expr ctx e1 in let e1 = evaluate_expr ctx e1 in
let args = List.map (evaluate_expr ctx) args 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 -> (fun ty ->
match Mark.remove ty with match Mark.remove ty with
| TOption _ -> | TOption _ ->
(Expr.einj (Expr.elit LUnit mark_e) Expr.none_constr (Expr.einj ~e:(Expr.elit LUnit mark_e) ~cons:Expr.none_constr
Expr.option_enum mark_e ~name:Expr.option_enum mark_e
: (_, _) boxed_gexpr) : (_, _) boxed_gexpr)
| _ -> | _ ->
Message.raise_spanned_error (Mark.get ty) 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 in
let to_interpret = let to_interpret =
Expr.make_app (Expr.box e) 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) (Expr.pos e)
in in
match Mark.remove (evaluate_expr ctx (Expr.unbox to_interpret)) with 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 in
let to_interpret = let to_interpret =
Expr.make_app (Expr.box e) 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) (Expr.pos e)
in in
match Mark.remove (evaluate_expr ctx (Expr.unbox to_interpret)) with match Mark.remove (evaluate_expr ctx (Expr.unbox to_interpret)) with
@ -888,5 +913,10 @@ let load_runtime_modules = function
List.iter List.iter
Dynlink.( Dynlink.(
fun m -> 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 modules

43
compiler/shared_ast/optimizations.ml
View File

@ -178,7 +178,7 @@ let rec optimize_expr :
when false when false
(* TODO: this case is buggy because of the box/unbox manipulation, it (* TODO: this case is buggy because of the box/unbox manipulation, it
should be fixed before removing this [false] value*) should be fixed before removing this [false] value*)
&& n1 = n2 && EnumName.equal n1 n2
&& all_match_cases_map_to_same_constructor cases1 n1 -> && all_match_cases_map_to_same_constructor cases1 n1 ->
(* iota-reduction when the matched expression is itself a match of the (* iota-reduction when the matched expression is itself a match of the
same enum mapping all constructors to themselves *) same enum mapping all constructors to themselves *)
@ -211,7 +211,7 @@ let rec optimize_expr :
(* beta reduction when variables not used. *) (* beta reduction when variables not used. *)
Mark.remove (Bindlib.msubst binder (List.map fst args |> Array.of_list)) Mark.remove (Bindlib.msubst binder (List.map fst args |> Array.of_list))
| EStructAccess { name; field; e = EStruct { name = name1; fields }, _ } | EStructAccess { name; field; e = EStruct { name = name1; fields }, _ }
when name = name1 -> when StructName.equal name name1 ->
Mark.remove (StructField.Map.find field fields) Mark.remove (StructField.Map.find field fields)
| EDefault { excepts; just; cons } -> ( | EDefault { excepts; just; cons } -> (
(* TODO: mechanically prove each of these optimizations correct *) (* 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 test_iota_reduction_1 () =
let x = Var.make "x" in 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 consA = EnumConstructor.fresh ("A", Pos.no_pos) in
let consB = EnumConstructor.fresh ("B", Pos.no_pos) in let consB = EnumConstructor.fresh ("B", Pos.no_pos) in
let consC = EnumConstructor.fresh ("C", Pos.no_pos) in let consC = EnumConstructor.fresh ("C", Pos.no_pos) in
let consD = EnumConstructor.fresh ("D", Pos.no_pos) in let consD = EnumConstructor.fresh ("D", Pos.no_pos) in
let nomark = Untyped { pos = 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 injA = Expr.einj ~e:(Expr.evar x nomark) ~cons:consA ~name:enumT nomark in
let injC = Expr.einj (Expr.evar x nomark) consC enumT nomark in let injC = Expr.einj ~e:(Expr.evar x nomark) ~cons:consC ~name:enumT nomark in
let injD = Expr.einj (Expr.evar x nomark) consD 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 = let cases : ('a, 't) boxed_gexpr EnumConstructor.Map.t =
EnumConstructor.Map.of_list 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; consB, Expr.eabs (Expr.bind [| x |] injD) [TAny, Pos.no_pos] nomark;
] ]
in in
let matchA = Expr.ematch injA enumT cases nomark in let matchA = Expr.ematch ~e:injA ~name:enumT ~cases nomark in
Alcotest.(check string) Alcotest.(check string)
"same string" "same string"
"before=match (A x)\n\ "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 }) )) (Untyped { pos = Pos.no_pos }) ))
let test_iota_reduction_2 () = 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 consA = EnumConstructor.fresh ("A", Pos.no_pos) in
let consB = EnumConstructor.fresh ("B", Pos.no_pos) in let consB = EnumConstructor.fresh ("B", Pos.no_pos) in
let consC = EnumConstructor.fresh ("C", 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 num n = Expr.elit (LInt (Runtime.integer_of_int n)) nomark in
let injAe e = Expr.einj e consA enumT nomark in let injAe e = Expr.einj ~e ~cons:consA ~name:enumT nomark in
let injBe e = Expr.einj e consB enumT nomark in let injBe e = Expr.einj ~e ~cons:consB ~name:enumT nomark in
let injCe e = Expr.einj e consC enumT nomark in let injCe e = Expr.einj ~e ~cons:consC ~name:enumT nomark in
let injDe e = Expr.einj e consD 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 injA x = injAe (Expr.evar x nomark) in *)
let injB x = injBe (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 = let matchA =
Expr.ematch Expr.ematch
(Expr.ematch (num 1) enumT ~e:
(cases_of_list (Expr.ematch ~e:(num 1) ~name:enumT
[ ~cases:
(consB, fun x -> injBe (injB x)); (consA, fun _x -> injAe (num 20)); (cases_of_list
]) [
nomark) (consB, fun x -> injBe (injB x));
enumT (consA, fun _x -> injAe (num 20));
(cases_of_list [consA, injC; consB, injD]) ])
nomark)
~name:enumT
~cases:(cases_of_list [consA, injC; consB, injD])
nomark nomark
in in
Alcotest.(check string) 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" | TDuration -> "duration"
| TDate -> "date") | 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 = let location (type a) (fmt : Format.formatter) (l : a glocation) : unit =
match l with match l with
| DesugaredScopeVar (v, _st) -> ScopeVar.format fmt (Mark.remove v) | DesugaredScopeVar { name; _ } -> ScopeVar.format fmt (Mark.remove name)
| ScopelangScopeVar v -> ScopeVar.format fmt (Mark.remove v) | ScopelangScopeVar { name; _ } -> ScopeVar.format fmt (Mark.remove name)
| SubScopeVar (_, subindex, subvar) -> | SubScopeVar { alias = subindex; var = subvar; _ } ->
Format.fprintf fmt "%a.%a" SubScopeName.format (Mark.remove subindex) Format.fprintf fmt "%a.%a" SubScopeName.format (Mark.remove subindex)
ScopeVar.format (Mark.remove subvar) 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 = let enum_constructor (fmt : Format.formatter) (c : EnumConstructor.t) : unit =
Format.fprintf fmt "@{<magenta>%a@}" EnumConstructor.format c 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 = let struct_field (fmt : Format.formatter) (c : StructField.t) : unit =
Format.fprintf fmt "@{<magenta>%a@}" StructField.format c 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 let rec typ_gen
(ctx : decl_ctx option) (ctx : decl_ctx option)
~(colors : Ocolor_types.color4 list) ~(colors : Ocolor_types.color4 list)
@ -137,14 +151,14 @@ let rec typ_gen
match ctx with match ctx with
| None -> Format.fprintf fmt "@[<hov 2>%a@]" EnumName.format e | None -> Format.fprintf fmt "@[<hov 2>%a@]" EnumName.format e
| Some ctx -> | 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 "[" Format.fprintf fmt "@[<hov 2>%a%a%a%a@]" EnumName.format e punctuation "["
(EnumConstructor.Map.format_bindings (EnumConstructor.Map.format_bindings
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ %a@ " punctuation "|") ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ %a@ " punctuation "|")
(fun fmt pp_case mty -> (fun fmt pp_case mty ->
Format.fprintf fmt "%t%a@ %a" pp_case punctuation ":" (typ ~colors) Format.fprintf fmt "%t%a@ %a" pp_case punctuation ":" (typ ~colors)
mty)) mty))
(EnumName.Map.find e ctx.ctx_enums) def punctuation "]")
punctuation "]")
| TOption t -> | TOption t ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" base_type "eoption" (typ ~colors) t Format.fprintf fmt "@[<hov 2>%a@ %a@]" base_type "eoption" (typ ~colors) t
| TArrow ([t1], t2) -> | TArrow ([t1], t2) ->
@ -499,7 +513,7 @@ module ExprGen (C : EXPR_PARAM) = struct
else else
match Mark.remove e with match Mark.remove e with
| EVar v -> var fmt v | EVar v -> var fmt v
| EExternal eref -> Qident.format fmt eref | EExternal { name } -> external_ref fmt name
| ETuple es -> | ETuple es ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" Format.fprintf fmt "@[<hov 2>%a%a%a@]"
(pp_color_string (List.hd colors)) (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 uid_list : Format.formatter -> Uid.MarkedString.info list -> unit
val enum_constructor : Format.formatter -> EnumConstructor.t -> unit val enum_constructor : Format.formatter -> EnumConstructor.t -> unit
val tlit : Format.formatter -> typ_lit -> 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 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 typ : decl_ctx -> Format.formatter -> typ -> unit
val lit : Format.formatter -> lit -> unit val lit : Format.formatter -> lit -> unit
val operator : ?debug:bool -> Format.formatter -> 'a operator -> 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_structs = StructName.Map.empty;
ctx_struct_fields = Ident.Map.empty; ctx_struct_fields = Ident.Map.empty;
ctx_scopes = ScopeName.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 = let get_scope_body { code_items; _ } scope =
match match
Scope.fold_left ~init:None 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 License for the specific language governing permissions and limitations under
the License. *) the License. *)
open Catala_utils
open Definitions open Definitions
(** {2 Program declaration context helpers} *) (** {2 Program declaration context helpers} *)
val empty_ctx : decl_ctx 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} *) (** {2 Transformations} *)
val map_exprs : val map_exprs :
@ -47,3 +52,4 @@ val to_expr : ((_ any, _) gexpr as 'e) program -> ScopeName.t -> 'e boxed
val equal : val equal :
(('a any, _) gexpr as 'e) program -> (('a any, _) gexpr as 'e) program -> bool (('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 (Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ *@ ") ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ *@ ")
(fun fmt t -> (fun fmt t -> format_typ fmt ~colors:(List.tl colors) t))
Format.fprintf fmt "%a" (format_typ ~colors:(List.tl colors)) t))
ts ts
(pp_color_string (List.hd colors)) (pp_color_string (List.hd colors))
")" ")"
| TStruct s -> Format.fprintf fmt "%a" A.StructName.format s | TStruct s -> A.StructName.format fmt s
| TEnum e -> Format.fprintf fmt "%a" A.EnumName.format e | TEnum e -> A.EnumName.format fmt e
| TOption t -> | TOption t ->
Format.fprintf fmt "@[<hov 2>option %a@]" Format.fprintf fmt "@[<hov 2>option %a@]"
(format_typ_with_parens ~colors:(List.tl colors)) (format_typ_with_parens ~colors:(List.tl colors))
@ -313,6 +312,7 @@ module Env = struct
scope_vars : A.typ A.ScopeVar.Map.t; scope_vars : A.typ A.ScopeVar.Map.t;
scopes : A.typ A.ScopeVar.Map.t A.ScopeName.Map.t; scopes : A.typ A.ScopeVar.Map.t A.ScopeName.Map.t;
toplevel_vars : A.typ A.TopdefName.Map.t; toplevel_vars : A.typ A.TopdefName.Map.t;
modules : 'e t A.ModuleName.Map.t;
} }
let empty (decl_ctx : A.decl_ctx) = let empty (decl_ctx : A.decl_ctx) =
@ -321,16 +321,17 @@ module Env = struct
{ {
structs = structs =
A.StructName.Map.map 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; decl_ctx.ctx_structs;
enums = enums =
A.EnumName.Map.map 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; decl_ctx.ctx_enums;
vars = Var.Map.empty; vars = Var.Map.empty;
scope_vars = A.ScopeVar.Map.empty; scope_vars = A.ScopeVar.Map.empty;
scopes = A.ScopeName.Map.empty; scopes = A.ScopeName.Map.empty;
toplevel_vars = A.TopdefName.Map.empty; toplevel_vars = A.TopdefName.Map.empty;
modules = A.ModuleName.Map.empty;
} }
let get t v = Var.Map.find_opt v t.vars 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 -> Option.bind (A.ScopeName.Map.find_opt scope t.scopes) (fun vmap ->
A.ScopeVar.Map.find_opt var 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 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 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 = let add_toplevel_var v typ t =
{ t with toplevel_vars = A.TopdefName.Map.add v typ t.toplevel_vars } { 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 open_scope scope_name t =
let scope_vars = let scope_vars =
A.ScopeVar.Map.union A.ScopeVar.Map.union
@ -361,6 +368,26 @@ module Env = struct
(A.ScopeName.Map.find scope_name t.scopes) (A.ScopeName.Map.find scope_name t.scopes)
in in
{ t with scope_vars } { 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 end
let add_pos e ty = Mark.add (Expr.pos e) ty let add_pos e ty = Mark.add (Expr.pos e) ty
@ -414,11 +441,14 @@ and typecheck_expr_top_down :
| A.ELocation loc -> | A.ELocation loc ->
let ty_opt = let ty_opt =
match loc with match loc with
| DesugaredScopeVar (v, _) | ScopelangScopeVar v -> | DesugaredScopeVar { name; _ } | ScopelangScopeVar { name } ->
Env.get_scope_var env (Mark.remove v) Env.get_scope_var env (Mark.remove name)
| SubScopeVar (scope, _, v) -> | SubScopeVar { scope; var; _ } ->
Env.get_subscope_out_var env scope (Mark.remove v) let env = Env.module_env (A.ScopeName.path scope) env in
| ToplevelVar v -> Env.get_toplevel_var env (Mark.remove v) 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 in
let ty = let ty =
match ty_opt with match ty_opt with
@ -463,14 +493,14 @@ and typecheck_expr_top_down :
"Mismatching field definitions for structure %a" A.StructName.format "Mismatching field definitions for structure %a" A.StructName.format
name name
in in
let fields' = let fields =
A.StructField.Map.mapi A.StructField.Map.mapi
(fun f_name f_e -> (fun f_name f_e ->
let f_ty = A.StructField.Map.find f_name str in let f_ty = A.StructField.Map.find f_name str in
typecheck_expr_top_down ~leave_unresolved ctx env f_ty f_e) typecheck_expr_top_down ~leave_unresolved ctx env f_ty f_e)
fields fields
in in
Expr.estruct name fields' mark Expr.estruct ~name ~fields mark
| A.EDStructAccess { e = e_struct; name_opt; field } -> | A.EDStructAccess { e = e_struct; name_opt; field } ->
let t_struct = let t_struct =
match name_opt with match name_opt with
@ -495,14 +525,14 @@ and typecheck_expr_top_down :
let fld_ty = let fld_ty =
let str = let str =
try A.StructName.Map.find name env.structs 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" Message.raise_spanned_error pos_e "No structure %a found"
A.StructName.format name A.StructName.format name
in in
let field = let field =
let candidate_structs = let candidate_structs =
try A.Ident.Map.find field ctx.ctx_struct_fields try A.Ident.Map.find field ctx.ctx_struct_fields
with Not_found -> with A.Ident.Map.Not_found _ ->
Message.raise_spanned_error Message.raise_spanned_error
(Expr.mark_pos context_mark) (Expr.mark_pos context_mark)
"Field @{<yellow>\"%s\"@} does not belong to structure \ "Field @{<yellow>\"%s\"@} does not belong to structure \
@ -510,7 +540,7 @@ and typecheck_expr_top_down :
field A.StructName.format name field A.StructName.format name
in in
try A.StructName.Map.find name candidate_structs try A.StructName.Map.find name candidate_structs
with Not_found -> with A.StructName.Map.Not_found _ ->
Message.raise_spanned_error Message.raise_spanned_error
(Expr.mark_pos context_mark) (Expr.mark_pos context_mark)
"@[<hov>Field @{<yellow>\"%s\"@}@ does not belong to@ structure \ "@[<hov>Field @{<yellow>\"%s\"@}@ does not belong to@ structure \
@ -526,17 +556,17 @@ and typecheck_expr_top_down :
A.StructField.Map.find field str A.StructField.Map.find field str
in in
let mark = mark_with_tau_and_unify fld_ty 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 } -> | A.EStructAccess { e = e_struct; name; field } ->
let fld_ty = let fld_ty =
let str = let str =
try A.StructName.Map.find name env.structs 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" Message.raise_spanned_error pos_e "No structure %a found"
A.StructName.format name A.StructName.format name
in in
try A.StructField.Map.find field str try A.StructField.Map.find field str
with Not_found -> with A.StructField.Map.Not_found _ ->
Message.raise_multispanned_error Message.raise_multispanned_error
[ [
None, pos_e; None, pos_e;
@ -551,7 +581,7 @@ and typecheck_expr_top_down :
typecheck_expr_top_down ~leave_unresolved ctx env typecheck_expr_top_down ~leave_unresolved ctx env
(unionfind (TStruct name)) e_struct (unionfind (TStruct name)) e_struct
in in
Expr.estructaccess e_struct' field name mark Expr.estructaccess ~e:e_struct' ~field ~name mark
| A.EInj { name; cons; e = e_enum } | A.EInj { name; cons; e = e_enum }
when Definitions.EnumName.equal name Expr.option_enum -> when Definitions.EnumName.equal name Expr.option_enum ->
if Definitions.EnumConstructor.equal cons Expr.some_constr then if Definitions.EnumConstructor.equal cons Expr.some_constr then
@ -560,7 +590,7 @@ and typecheck_expr_top_down :
let e_enum' = let e_enum' =
typecheck_expr_top_down ~leave_unresolved ctx env cell_type e_enum typecheck_expr_top_down ~leave_unresolved ctx env cell_type e_enum
in in
Expr.einj e_enum' cons name mark Expr.einj ~name ~cons ~e:e_enum' mark
else else
(* None constructor *) (* None constructor *)
let cell_type = unionfind (TAny (Any.fresh ())) in 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 typecheck_expr_top_down ~leave_unresolved ctx env
(unionfind (TLit TUnit)) e_enum (unionfind (TLit TUnit)) e_enum
in in
Expr.einj e_enum' cons name mark Expr.einj ~name ~cons ~e:e_enum' mark
| A.EInj { name; cons; e = e_enum } -> | A.EInj { name; cons; e = e_enum } ->
let mark = mark_with_tau_and_unify (unionfind (TEnum name)) in let mark = mark_with_tau_and_unify (unionfind (TEnum name)) in
let e_enum' = let e_enum' =
@ -577,7 +607,7 @@ and typecheck_expr_top_down :
(A.EnumConstructor.Map.find cons (A.EnumName.Map.find name env.enums)) (A.EnumConstructor.Map.find cons (A.EnumName.Map.find name env.enums))
e_enum e_enum
in in
Expr.einj e_enum' cons name mark Expr.einj ~e:e_enum' ~cons ~name mark
| A.EMatch { e = e1; name; cases } | A.EMatch { e = e1; name; cases }
when Definitions.EnumName.equal name Expr.option_enum -> when Definitions.EnumName.equal name Expr.option_enum ->
let cell_type = unionfind ~pos:e1 (TAny (Any.fresh ())) in 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 t_ret = unionfind ~pos:e (TAny (Any.fresh ())) in
let mark = mark_with_tau_and_unify t_ret 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 e1' = typecheck_expr_top_down ~leave_unresolved ctx env t_arg e1 in
let cases' = let cases =
A.EnumConstructor.Map.merge A.EnumConstructor.Map.merge
(fun _ e e_ty -> (fun _ e e_ty ->
match e, e_ty with match e, e_ty with
@ -603,8 +633,7 @@ and typecheck_expr_top_down :
| _ -> assert false) | _ -> assert false)
cases cases_ty cases cases_ty
in in
Expr.ematch ~e:e1' ~name ~cases mark
Expr.ematch e1' name cases' mark
| A.EMatch { e = e1; name; cases } -> | A.EMatch { e = e1; name; cases } ->
let cases_ty = A.EnumName.Map.find name ctx.A.ctx_enums in let cases_ty = A.EnumName.Map.find name ctx.A.ctx_enums in
let t_ret = unionfind ~pos:e1 (TAny (Any.fresh ())) 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)) typecheck_expr_top_down ~leave_unresolved ctx env (unionfind (TEnum name))
e1 e1
in in
let cases' = let cases =
A.EnumConstructor.Map.mapi A.EnumConstructor.Map.mapi
(fun c_name e -> (fun c_name e ->
let c_ty = A.EnumConstructor.Map.find c_name cases_ty in 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) typecheck_expr_top_down ~leave_unresolved ctx env e_ty e)
cases cases
in in
Expr.ematch e1' name cases' mark Expr.ematch ~e:e1' ~name ~cases mark
| A.EScopeCall { scope; args } -> | A.EScopeCall { scope; args } ->
let path = A.ScopeName.path scope in
let scope_out_struct = let scope_out_struct =
let ctx = Program.module_ctx ctx path in
(A.ScopeName.Map.find scope ctx.ctx_scopes).out_struct_name (A.ScopeName.Map.find scope ctx.ctx_scopes).out_struct_name
in in
let mark = mark_with_tau_and_unify (unionfind (TStruct scope_out_struct)) 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' = let args' =
A.ScopeVar.Map.mapi A.ScopeVar.Map.mapi
(fun name -> (fun name ->
@ -638,7 +672,7 @@ and typecheck_expr_top_down :
(ast_to_typ (A.ScopeVar.Map.find name vars))) (ast_to_typ (A.ScopeVar.Map.find name vars)))
args args
in in
Expr.escopecall scope args' mark Expr.escopecall ~scope ~args:args' mark
| A.ERaise ex -> Expr.eraise ex context_mark | A.ERaise ex -> Expr.eraise ex context_mark
| A.ECatch { body; exn; handler } -> | A.ECatch { body; exn; handler } ->
let body' = typecheck_expr_top_down ~leave_unresolved ctx env tau body in 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) "Variable %s not found in the current context" (Bindlib.name_of v)
in in
Expr.evar (Var.translate v) (mark_with_tau_and_unify tau') Expr.evar (Var.translate v) (mark_with_tau_and_unify tau')
| A.EExternal 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 = let ty =
try Qident.Map.find eref ctx.ctx_modules let not_found pr x =
with Not_found ->
Message.raise_spanned_error pos_e Message.raise_spanned_error pos_e
"Could not resolve the reference to %a.@ Make sure the corresponding \ "Could not resolve the reference to %a.@ Make sure the corresponding \
module was properly loaded?" module was properly loaded?"
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 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.ELit lit -> Expr.elit lit (ty_mark (lit_type lit))
| A.ETuple es -> | A.ETuple es ->
let tys = List.map (fun _ -> unionfind (TAny (Any.fresh ()))) es in 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 (** Typing for the default calculus. Because of the error terms, we perform type
inference using the classical W algorithm with union-find unification. *) inference using the classical W algorithm with union-find unification. *)
open Catala_utils
open Definitions open Definitions
module Env : sig module Env : sig
@ -27,7 +28,12 @@ module Env : sig
val add_toplevel_var : TopdefName.t -> typ -> 'e t -> 'e t 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_var : ScopeVar.t -> typ -> 'e t -> 'e t
val add_scope : ScopeName.t -> vars:typ ScopeVar.Map.t -> '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 open_scope : ScopeName.t -> 'e t -> 'e t
val dump : Format.formatter -> 'e t -> unit
(** For debug purposes *)
end end
(** In the following functions, the [~leave_unresolved] labeled parameter (** In the following functions, the [~leave_unresolved] labeled parameter

8
compiler/shared_ast/var.ml
View File

@ -88,7 +88,12 @@ end
maps) *) maps) *)
module Map = struct module Map = struct
open Generic 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 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 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 keys m = keys m |> List.map get
let values m = values m let values m = values m
let format_keys ?pp_sep m = format_keys ?pp_sep m
(* Add more as needed *) (* Add more as needed *)
end end

9
compiler/shared_ast/var.mli
View File

@ -57,6 +57,9 @@ end
Extend as needed *) Extend as needed *)
module Map : sig module Map : sig
type ('e, 'x) t type ('e, 'x) t
type k0
exception Not_found of k0
val empty : ('e, 'x) t val empty : ('e, 'x) t
val singleton : 'e var -> 'x -> ('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 fold : ('e var -> 'x -> 'acc -> 'acc) -> ('e, 'x) t -> 'acc -> 'acc
val keys : ('e, 'x) t -> 'e var list val keys : ('e, 'x) t -> 'e var list
val values : ('e, 'x) t -> 'x list val values : ('e, 'x) t -> 'x list
val format_keys :
?pp_sep:(Format.formatter -> unit -> unit) ->
Format.formatter ->
('e, 'x) t ->
unit
end end

9
compiler/surface/ast.ml
View File

@ -251,7 +251,7 @@ and scope_decl_context_io = {
and scope_decl_context_scope = { and scope_decl_context_scope = {
scope_decl_context_scope_name : lident Mark.pos; 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; scope_decl_context_scope_attribute : scope_decl_context_io;
} }
@ -309,11 +309,14 @@ and law_structure =
| LawText of (string[@opaque]) | LawText of (string[@opaque])
| CodeBlock of code_block * source_repr * bool (* Metadata if true *) | 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 = { and program = {
program_interfaces :
((Shared_ast.Qident.path[@opaque]) * code_item Mark.pos) list;
program_items : law_structure list; program_items : law_structure list;
program_source_files : (string[@opaque]) list; program_source_files : (string[@opaque]) list;
program_modules : (uident * interface) list;
} }
and source_file = law_structure 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 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 source_file: BEGIN_CODE DECLARATION SCOPE UIDENT COLON LIDENT YEAR
## ##
## Ends in an error in state: 349. ## 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: ## The known suffix of the stack is as follows:
## lident ## lident
@ -4007,7 +3973,7 @@ source_file: BEGIN_CODE DECLARATION SCOPE UIDENT COLON LIDENT SCOPE YEAR
## ##
## Ends in an error in state: 350. ## 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: ## The known suffix of the stack is as follows:
## lident SCOPE ## lident SCOPE

2
compiler/surface/parser.mly
View File

@ -574,7 +574,7 @@ let scope_decl_item :=
scope_decl_context_item_states = states; scope_decl_context_item_states = states;
} }
} }
| i = lident ; SCOPE ; c = uident ; { | i = lident ; SCOPE ; c = addpos(quident) ; {
ContextScope{ ContextScope{
scope_decl_context_scope_name = i; scope_decl_context_scope_name = i;
scope_decl_context_scope_sub_scope = c; 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 -> ()); (match input with Some input -> close_in input | None -> ());
let program = expand_includes source_file_name commands language in let program = expand_includes source_file_name commands language in
{ {
program_interfaces = [];
program_items = program.Ast.program_items; program_items = program.Ast.program_items;
program_source_files = source_file_name :: program.Ast.program_source_files; 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 (** 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 sub_source = File.(source_dir / Mark.remove sub_source) in
let includ_program = parse_source_file (FileName sub_source) language in let includ_program = parse_source_file (FileName sub_source) language in
{ {
program_interfaces = [];
Ast.program_source_files = Ast.program_source_files =
acc.Ast.program_source_files @ includ_program.program_source_files; acc.Ast.program_source_files @ includ_program.program_source_files;
Ast.program_items = Ast.program_items =
acc.Ast.program_items @ includ_program.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') -> | Ast.LawHeading (heading, commands') ->
let { let {
Ast.program_interfaces = _;
Ast.program_items = commands'; Ast.program_items = commands';
Ast.program_source_files = new_sources; Ast.program_source_files = new_sources;
Ast.program_modules = new_modules;
} = } =
expand_includes source_file commands' language expand_includes source_file commands' language
in in
{ {
Ast.program_interfaces = [];
Ast.program_source_files = acc.Ast.program_source_files @ new_sources; Ast.program_source_files = acc.Ast.program_source_files @ new_sources;
Ast.program_items = Ast.program_items =
acc.Ast.program_items @ [Ast.LawHeading (heading, commands')]; 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] }) | i -> { acc with Ast.program_items = acc.Ast.program_items @ [i] })
{ {
Ast.program_interfaces = [];
Ast.program_source_files = []; Ast.program_source_files = [];
Ast.program_items = []; Ast.program_items = [];
Ast.program_modules = [];
} }
commands commands
@ -297,30 +298,16 @@ let get_interface program =
in in
List.fold_left filter [] program.Ast.program_items List.fold_left filter [] program.Ast.program_items
let qualify_interface path code_items =
List.map (fun item -> path, item) code_items
(** {1 API} *) (** {1 API} *)
let add_interface source_file language path program = let load_interface source_file language =
let interface = parse_source_file source_file language |> get_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 parse_top_level_file let parse_top_level_file
(source_file : Cli.input_file) (source_file : Cli.input_file)
(language : Cli.backend_lang) : Ast.program = (language : Cli.backend_lang) : Ast.program =
let program = parse_source_file source_file language in let program = parse_source_file source_file language in
let interface = get_interface program in
{ {
program with program with
Ast.program_items = law_struct_list_to_tree program.Ast.program_items; 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 open Catala_utils
val add_interface : val load_interface : Cli.input_file -> Cli.backend_lang -> Ast.interface
Cli.input_file -> (** Reads only declarations in metadata in the supplied input file, and only
Cli.backend_lang -> keeps type information *)
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 parse_top_level_file : Cli.input_file -> Cli.backend_lang -> Ast.program 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 mk_struct. The accessors of this constructor correspond to the field
accesses *) accesses *)
let accessors = List.hd (Datatype.get_accessors z3_struct) in let accessors = List.hd (Datatype.get_accessors z3_struct) in
let idx_mappings = let fields = StructName.Map.find name ctx.ctx_decl.ctx_structs in
List.combine let idx_mappings = List.combine (StructField.Map.keys fields) accessors in
(StructField.Map.keys
(StructName.Map.find name ctx.ctx_decl.ctx_structs))
accessors
in
let _, accessor = let _, accessor =
List.find (fun (field1, _) -> StructField.equal field field1) idx_mappings List.find (fun (field1, _) -> StructField.equal field field1) idx_mappings
in 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_enum = find_or_create_enum ctx name in
let ctx, z3_arg = translate_expr ctx e in let ctx, z3_arg = translate_expr ctx e in
let ctrs = Datatype.get_constructors z3_enum 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 *) (* This should always succeed if the expression is well-typed in dcalc *)
let idx_mappings = let idx_mappings = List.combine (EnumConstructor.Map.keys cons_map) ctrs in
List.combine
(EnumConstructor.Map.keys
(EnumName.Map.find name ctx.ctx_decl.ctx_enums))
ctrs
in
let _, ctr = let _, ctr =
List.find List.find
(fun (cons1, _) -> EnumConstructor.equal cons cons1) (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: pass_all_tests:
@cd ..;OCAMLRUNPARAM= $(CLERK) examples @cd ..; $(CLERK) examples
reset_all_tests: CLERK_OPTS+=--reset reset_all_tests: CLERK_OPTS+=--reset
reset_all_tests: reset_all_tests:
@cd ..;OCAMLRUNPARAM= $(CLERK) examples @cd ..; $(CLERK) examples
%.catala_en %.catala_fr %.catala_pl: .FORCE %.catala_en %.catala_fr %.catala_pl: .FORCE
# Here we cd to the root of the Catala repository such that the paths \ # Here we cd to the root of the Catala repository such that the paths \
# displayed in error messages start with `examples/` uniformly. # displayed in error messages start with `examples/` uniformly.
@cd ..;OCAMLRUNPARAM= $(CLERK) examples/$@ @cd ..; $(CLERK) examples/$@
.FORCE: .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" or "content"
Error token: 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 11 │ context my_gaming scope GamingAuthorized
│ ‾‾‾‾‾ │ ‾‾‾‾‾
Last good token: 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 11 │ context my_gaming scope GamingAuthorized
│ ‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾
@ -79,13 +79,13 @@ You could have written : "condition",
or "content" or "content"
Error token: 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 11 │ context my_gaming scope GamingAuthorized
│ ‾‾‾‾‾ │ ‾‾‾‾‾
Last good token: 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 11 │ context my_gaming scope GamingAuthorized
│ ‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾
@ -123,13 +123,13 @@ You could have written : "condition",
or "content" or "content"
Error token: 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 11 │ context my_gaming scope GamingAuthorized
│ ‾‾‾‾‾ │ ‾‾‾‾‾
Last good token: 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 11 │ context my_gaming scope GamingAuthorized
│ ‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾
@ -169,13 +169,13 @@ You could have written : "condition",
or "content" or "content"
Error token: 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 11 │ context my_gaming scope GamingAuthorized
│ ‾‾‾‾‾ │ ‾‾‾‾‾
Last good token: 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 11 │ context my_gaming scope GamingAuthorized
│ ‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾

14
french_law/ocaml/api.ml
View File

@ -30,17 +30,17 @@ let compute_allocations_familiales
let result = let result =
AF.interface_allocations_familiales AF.interface_allocations_familiales
{ {
AF.InterfaceAllocationsFamilialesIn.i_date_courante_in = current_date; AF.InterfaceAllocationsFamiliales_in.i_date_courante_in = current_date;
AF.InterfaceAllocationsFamilialesIn.i_enfants_in = children; AF.InterfaceAllocationsFamiliales_in.i_enfants_in = children;
AF.InterfaceAllocationsFamilialesIn.i_ressources_menage_in = AF.InterfaceAllocationsFamiliales_in.i_ressources_menage_in =
money_of_units_int income; money_of_units_int income;
AF.InterfaceAllocationsFamilialesIn.i_residence_in = residence; AF.InterfaceAllocationsFamiliales_in.i_residence_in = residence;
AF.InterfaceAllocationsFamilialesIn AF.InterfaceAllocationsFamiliales_in
.i_personne_charge_effective_permanente_est_parent_in = is_parent; .i_personne_charge_effective_permanente_est_parent_in = is_parent;
AF.InterfaceAllocationsFamilialesIn AF.InterfaceAllocationsFamiliales_in
.i_personne_charge_effective_permanente_remplit_titre_I_in = .i_personne_charge_effective_permanente_remplit_titre_I_in =
fills_title_I; fills_title_I;
AF.InterfaceAllocationsFamilialesIn AF.InterfaceAllocationsFamiliales_in
.i_avait_enfant_a_charge_avant_1er_janvier_2012_in = .i_avait_enfant_a_charge_avant_1er_janvier_2012_in =
had_rights_open_before_2012; had_rights_open_before_2012;
} }

4
french_law/ocaml/bench.ml
View File

@ -116,7 +116,7 @@ let run_test_allocations_familiales () =
| Runtime.AssertionFailed _ -> () | Runtime.AssertionFailed _ -> ()
let aides_logement_input : let aides_logement_input :
Law_source.Aides_logement.CalculetteAidesAuLogementGardeAlterneeIn.t = Law_source.Aides_logement.CalculetteAidesAuLogementGardeAlternee_in.t =
{ {
menage_in = menage_in =
{ {
@ -137,7 +137,7 @@ let aides_logement_input :
false; false;
logement_meuble_d842_2 = false; logement_meuble_d842_2 = false;
changement_logement_d842_4 = changement_logement_d842_4 =
Law_source.Aides_logement.ChangementLogementD8424 Law_source.Aides_logement.ChangementLogementD842_4
.PasDeChangement .PasDeChangement
(); ();
loyer_principal = Runtime.money_of_units_int 450; 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/$@ @cd ..; $(CLERK) tests/$@
pass_all_tests: pass_all_tests:
@cd ..;OCAMLRUNPARAM= $(CLERK) tests @cd ..; $(CLERK) tests
reset_all_tests: CLERK_OPTS+=--reset reset_all_tests: CLERK_OPTS+=--reset
reset_all_tests: 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 division by zero at runtime
The division operator: 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. 20 │ definition i equals 1. / 0.
│ ‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾
@ -45,7 +45,7 @@ The division operator:
└─ with decimals └─ with decimals
The null denominator: 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. 20 │ definition i equals 1. / 0.
│ ‾‾ │ ‾‾
@ -60,7 +60,7 @@ $ catala Interpret -s Int
division by zero at runtime division by zero at runtime
The division operator: 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 10 │ definition i equals 1 / 0
│ ‾‾‾‾‾ │ ‾‾‾‾‾
@ -68,7 +68,7 @@ The division operator:
└─ with integers └─ with integers
The null denominator: 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 10 │ definition i equals 1 / 0
│ ‾ │ ‾
@ -83,7 +83,7 @@ $ catala Interpret -s Money
division by zero at runtime division by zero at runtime
The division operator: 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 30 │ definition i equals $10.0 / $0.0
│ ‾‾‾‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾‾‾‾
@ -91,7 +91,7 @@ The division operator:
└─ with money └─ with money
The null denominator: 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 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] [ERROR]
Please add parentheses to explicit which of these operators should be applied first 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 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 │ 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 I don't know how to apply operator >= on types integer and
money 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 10 │ definition list_high_count equals number of (m >= $7) for m among list
│ ‾‾ │ ‾‾
└─ Article └─ Article
Type integer coming from expression: 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 5 │ context list content collection integer
│ ‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾
└─ Article └─ Article
Type money coming from expression: 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 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 └─⯈ bool
Error coming from typechecking the following expression: 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 9 │ assertion x
│ ‾ │ ‾
└─ Test └─ Test
Type integer coming from expression: 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 5 │ output x content integer
│ ‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾
└─ Test └─ Test
Type bool coming from expression: 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 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 └─⯈ bool
Error coming from typechecking the following expression: 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 8 │ definition test_var equals 10 xor 20
│ ‾‾ │ ‾‾
└─ 'xor' should be a boolean operator └─ 'xor' should be a boolean operator
Type integer coming from expression: 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 8 │ definition test_var equals 10 xor 20
│ ‾‾ │ ‾‾
└─ 'xor' should be a boolean operator └─ 'xor' should be a boolean operator
Type bool coming from expression: 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 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] [ERROR]
You cannot set multiple date rounding modes 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 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 12 │ date round increasing
│ ‾‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾‾

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

@ -45,14 +45,14 @@ $ catala Interpret -s Ge
[ERROR] [ERROR]
Cannot compare together durations that cannot be converted to a precise number of days 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 40 │ definition d equals 1 month >= 2 day
│ ‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾
└┬ `UncomparableDurations` exception management └┬ `UncomparableDurations` exception management
└─ `>=` operator └─ `>=` 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 40 │ definition d equals 1 month >= 2 day
│ ‾‾‾‾‾ │ ‾‾‾‾‾
@ -66,14 +66,14 @@ $ catala Interpret -s Gt
[ERROR] [ERROR]
Cannot compare together durations that cannot be converted to a precise number of days 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 30 │ definition d equals 1 month > 2 day
│ ‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾
└┬ `UncomparableDurations` exception management └┬ `UncomparableDurations` exception management
└─ `<=` operator └─ `<=` 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 30 │ definition d equals 1 month > 2 day
│ ‾‾‾‾‾ │ ‾‾‾‾‾
@ -87,14 +87,14 @@ $ catala Interpret -s Le
[ERROR] [ERROR]
Cannot compare together durations that cannot be converted to a precise number of days 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 20 │ definition d equals 1 month <= 2 day
│ ‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾
└┬ `UncomparableDurations` exception management └┬ `UncomparableDurations` exception management
└─ `<=` operator └─ `<=` 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 20 │ definition d equals 1 month <= 2 day
│ ‾‾‾‾‾ │ ‾‾‾‾‾
@ -108,14 +108,14 @@ $ catala Interpret -s Lt
[ERROR] [ERROR]
Cannot compare together durations that cannot be converted to a precise number of days 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 10 │ definition d equals 1 month < 2 day
│ ‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾
└┬ `UncomparableDurations` exception management └┬ `UncomparableDurations` exception management
└─ `<` operator └─ `<` 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 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-test-inline
$ catala Interpret -s A --message=gnu $ 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. 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: 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:9.56-9.57: [ERROR] This consequence has a valid justification:
#return code 123# #return code 123#
``` ```

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

@ -13,7 +13,7 @@ scope A:
$ catala Interpret -s A $ catala Interpret -s A
[WARNING] In scope "A", the variable "y" is declared but never defined; did you forget something? [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 6 │ output y content boolean
│ ‾ │ ‾
@ -21,7 +21,7 @@ $ catala Interpret -s A
[ERROR] [ERROR]
This variable evaluated to an empty term (no rule that defined it applied in this situation) 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 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] [ERROR]
This variable evaluated to an empty term (no rule that defined it applied in this situation) 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 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 "." or "."
Error token: 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 8 │ definition wrong_definition = 1
│ ‾ │ ‾
Last good token: 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 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 $ catala Interpret -s A
[WARNING] These definitions have identical justifications and consequences; is it a mistake? [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 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 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] [ERROR]
This constructor name is ambiguous, it can belong to E or F. Desambiguate it by prefixing it with the enum name. 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 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] [ERROR]
Couldn't infer the enumeration name from lonely wildcard (wildcard cannot be used as single match case) 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 15 │ -- anything : 31
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾

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

@ -23,13 +23,13 @@ $ catala Interpret -s A
[ERROR] [ERROR]
The constructor Case3 has been matched twice: 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 18 │ -- Case3 : true
│ ‾‾‾‾ │ ‾‾‾‾
└─ Article └─ Article
┌─⯈ tests/test_enum/bad/duplicate_case.catala_en:17.16-17.21: ┌─⯈ duplicate_case.catala_en:17.16-17.21:
└──┐ └──┐
17 │ -- Case3 : false 17 │ -- Case3 : false
│ ‾‾‾‾‾ │ ‾‾‾‾‾

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

@ -12,7 +12,7 @@ $ catala Typecheck
[ERROR] [ERROR]
The enum Foo does not have any cases; give it some for Catala to be able to accept it. 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 │ declaration enumeration Foo:
│ ‾‾‾ │ ‾‾‾

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

@ -20,7 +20,7 @@ scope A:
$ catala Interpret -s A $ catala Interpret -s A
[WARNING] The constructor "Case3" of enumeration "E" is never used; maybe it's unnecessary? [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 7 │ -- Case3
│ ‾‾‾‾‾ │ ‾‾‾‾‾
@ -28,7 +28,7 @@ $ catala Interpret -s A
[ERROR] [ERROR]
The constructor Case3 of enum E is missing from this pattern matching 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 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 Wildcard must be the last match case
Not ending wildcard: 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 19 │ -- anything : 31
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
@ -50,7 +50,7 @@ Not ending wildcard:
└─ Wildcard can't be the first case └─ Wildcard can't be the first case
Next reachable 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 20 │ -- Case2 : 42
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾‾‾‾‾
@ -65,7 +65,7 @@ $ catala Interpret -s Middle_case
Wildcard must be the last match case Wildcard must be the last match case
Not ending wildcard: 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 19 │ -- anything : 31
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
@ -73,7 +73,7 @@ Not ending wildcard:
└─ Wildcard can't be the first case └─ Wildcard can't be the first case
Next reachable 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 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 └─⯈ F
Error coming from typechecking the following expression: 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 28 │ definition y equals x with pattern Case3
│ ‾ │ ‾
└─ Article └─ Article
Type E coming from expression: 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 17 │ context x content E
│ ‾ │ ‾
└─ Article └─ Article
Type F coming from expression: 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 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 └─⯈ F
Error coming from typechecking the following expression: 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 18 │ definition y equals x with pattern Case3
│ ‾ │ ‾
└─ Article └─ Article
Type E coming from expression: 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 13 │ context x content E
│ ‾ │ ‾
└─ Article └─ Article
Type F coming from expression: 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 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 └─⯈ F
Error coming from typechecking the following expression: 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 17 │ definition y equals x with pattern Case3
│ ‾ │ ‾
└─ Test └─ Test
Type E coming from expression: 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 12 │ context x content E
│ ‾ │ ‾
└─ Test └─ Test
Type F coming from expression: 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 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). (it's probably a typographical error).
Here is your code : 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 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] [ERROR]
This case matches a constructor of enumeration E but previous case were matching constructors of enumeration F 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 21 │ -- Case4 : true
│ ‾‾‾‾‾ │ ‾‾‾‾‾

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

@ -21,7 +21,7 @@ scope A:
$ catala Interpret -s A $ catala Interpret -s A
[WARNING] Unreachable match case, all constructors of the enumeration E are already specified [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 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). (it's probably a typographical error).
Here is your code : 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 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 This exception can refer to several definitions. Try using labels to disambiguate
Ambiguous exception 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 12 │ exception
│ ‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾
@ -28,14 +28,14 @@ Ambiguous exception
└─ Test └─ Test
Candidate definition 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 10 │ definition x equals 1
│ ‾ │ ‾
└─ Test └─ Test
Candidate definition 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 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] [ERROR]
Unknown label for the scope variable x: "base_y" 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 12 │ exception base_y
│ ‾‾‾‾‾‾ │ ‾‾‾‾‾‾

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

@ -23,7 +23,7 @@ $ catala Interpret -s A
[ERROR] [ERROR]
Exception cycle detected when defining x: each of these 3 exceptions applies over the previous one, and the first applies over the last 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 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 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 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 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 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] [ERROR]
This exception does not have a corresponding definition 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 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 This exception can refer to several definitions. Try using labels to disambiguate
Ambiguous exception 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 18 │ exception
│ ‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾
@ -34,14 +34,14 @@ Ambiguous exception
└─ Test └─ Test
Candidate definition 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 16 │ definition y equals 4
│ ‾ │ ‾
└─ Test └─ Test
Candidate definition 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 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] [ERROR]
Cannot define rule as an exception to itself 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 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. There is a conflict between multiple valid consequences for assigning the same variable.
This consequence has a valid justification: 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 12 │ definition x equals 1
│ ‾ │ ‾
└─ Test └─ Test
This consequence has a valid justification: 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 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 $ catala Scopelang -s Foo
[WARNING] These definitions have identical justifications and consequences; is it a mistake? [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 9 │ definition x equals 1
│ ‾‾‾‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾‾‾‾
└─ Foo └─ 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 8 │ definition x equals 1
│ ‾‾‾‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾‾‾‾
@ -39,13 +39,13 @@ Dcalc translation below.
$ catala Dcalc -s Foo $ catala Dcalc -s Foo
[WARNING] These definitions have identical justifications and consequences; is it a mistake? [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 9 │ definition x equals 1
│ ‾‾‾‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾‾‾‾
└─ Foo └─ 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 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". Printing the tree of exceptions for the definitions of variable "x" of scope "Foo".
[RESULT] [RESULT]
Definitions with label "base": 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 9 │ label base definition x under condition
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
└─ Test └─ 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 13 │ label base definition x under condition
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
└─ Test └─ Test
[RESULT] [RESULT]
Definitions with label "intermediate": 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 17 │ label intermediate exception base definition x under condition
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
└─ Test └─ 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 21 │ label intermediate exception base definition x under condition
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
└─ Test └─ Test
[RESULT] [RESULT]
Definitions with label "exception_to_intermediate": 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 25 │ exception intermediate definition x under condition
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
└─ Test └─ 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 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. There is a conflict between multiple valid consequences for assigning the same variable.
This consequence has a valid justification: 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 14 │ definition f of x under condition (x >= x) consequence equals x + x
│ ‾‾‾‾‾ │ ‾‾‾‾‾
└─ Article └─ Article
This consequence has a valid justification: 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 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') Function argument name mismatch between declaration ('x') and definition ('y')
Argument declared here: 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 4 │ internal f1 content decimal depends on x content integer
│ ‾ │ ‾
Defined here: 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 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