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

Merge branch 'master' into fix_362

Browse Source
This commit is contained in:
Denis Merigoux 2022-12-07 15:32:08 +01:00
commit 619461dba8
No known key found for this signature in database
GPG Key ID: EE99DCFA365C3EE3
196 changed files with 1925 additions and 1842 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
build_system/clerk_driver.ml
View File

@ -16,7 +16,7 @@
the License. *)
open Cmdliner
open Utils
open Catala_utils
open Ninja_utils
module Nj = Ninja_utils

2
build_system/dune
View File

@ -9,7 +9,7 @@
(public_name clerk.driver)
(libraries
catala.runtime_ocaml
catala.utils
catala.catala_utils
ninja_utils
cmdliner
re

6
compiler/utils/utils.mld → compiler/catala_utils/catala_utils.mld
View File

@ -7,12 +7,12 @@ In {{: desugared.html} the desugared representation} or in the
global identifiers. These identifiers use OCaml's type system to statically
distinguish e.g. a scope identifier from a struct identifier.
The {!module: Utils.Uid} module provides a generative functor whose output is
The {!module: Uid} module provides a generative functor whose output is
a fresh sort of global identifiers.
Related modules:
{!modules: Utils.Uid}
{!modules: Uid}
{1 Source code positions}
@ -22,7 +22,7 @@ code. These annotations are critical to produce readable error messages.
Related modules:
{!modules: Utils.Pos}
{!modules: Pos}
{1 Error messages}

0
compiler/utils/cli.ml → compiler/catala_utils/cli.ml
View File

0
compiler/utils/cli.mli → compiler/catala_utils/cli.mli
View File

6
compiler/utils/dune → compiler/catala_utils/dune
View File

@ -1,8 +1,8 @@
(library
(name utils)
(public_name catala.utils)
(name catala_utils)
(public_name catala.catala_utils)
(libraries cmdliner ubase ANSITerminal re bindlib catala.runtime_ocaml))
(documentation
(package catala)
(mld_files utils))
(mld_files catala_utils))

0
compiler/utils/errors.ml → compiler/catala_utils/errors.ml
View File

0
compiler/utils/errors.mli → compiler/catala_utils/errors.mli
View File

0
compiler/utils/file.ml → compiler/catala_utils/file.ml
View File

0
compiler/utils/file.mli → compiler/catala_utils/file.mli
View File

0
compiler/utils/marked.ml → compiler/catala_utils/marked.ml
View File

0
compiler/utils/marked.mli → compiler/catala_utils/marked.mli
View File

85
compiler/utils/pos.ml → compiler/catala_utils/pos.ml
View File

@ -79,11 +79,11 @@ let to_string (pos : t) : string =
let to_string_short (pos : t) : string =
let s, e = pos.code_pos in
if e.Lexing.pos_lnum = s.Lexing.pos_lnum then
Printf.sprintf "%s:%d.%d-%d" s.Lexing.pos_fname s.Lexing.pos_lnum
Printf.sprintf "%s:%d.%d-%d:" s.Lexing.pos_fname s.Lexing.pos_lnum
(s.Lexing.pos_cnum - s.Lexing.pos_bol)
(e.Lexing.pos_cnum - e.Lexing.pos_bol)
else
Printf.sprintf "%s:%d.%d-%d.%d" s.Lexing.pos_fname s.Lexing.pos_lnum
Printf.sprintf "%s:%d.%d-%d.%d:" s.Lexing.pos_fname s.Lexing.pos_lnum
(s.Lexing.pos_cnum - s.Lexing.pos_bol)
e.Lexing.pos_lnum
(e.Lexing.pos_cnum - e.Lexing.pos_bol)
@ -102,6 +102,27 @@ let string_repeat n s =
done;
Bytes.to_string buf
(* Note: this should do, but remains incorrect for combined unicode characters
that display as one (e.g. `e` + postfix `'`). We should switch to Uuseg at
some poing *)
let string_columns s =
let len = String.length s in
let rec aux ncols i =
if i >= len then ncols
else if s.[i] = '\t' then aux (ncols + 8) (i + 1)
else
aux (ncols + 1) (i + Uchar.utf_decode_length (String.get_utf_8_uchar s i))
in
aux 0 0
let utf8_byte_index s ui0 =
let rec aux bi ui =
if ui >= ui0 then bi
else
aux (bi + Uchar.utf_decode_length (String.get_utf_8_uchar s bi)) (ui + 1)
in
aux 0 0
let retrieve_loc_text (pos : t) : string =
try
let filename = get_file pos in
@ -132,34 +153,32 @@ let retrieve_loc_text (pos : t) : string =
let print_matched_line (line : string) (line_no : int) : string =
let line_indent = indent_number line in
let error_indicator_style = [ANSITerminal.red; ANSITerminal.Bold] in
line
^
if line_no >= sline && line_no <= eline then
"\n"
^
if line_no = sline && line_no = eline then
Cli.with_style error_indicator_style "%*s%s"
(get_start_column pos - 1)
""
(string_repeat
(max (get_end_column pos - get_start_column pos) 0)
"‾")
else if line_no = sline && line_no <> eline then
Cli.with_style error_indicator_style "%*s%s"
(get_start_column pos - 1)
""
(string_repeat
(max (String.length line - get_start_column pos) 0)
"‾")
else if line_no <> sline && line_no <> eline then
Cli.with_style error_indicator_style "%*s%s" line_indent ""
(string_repeat (max (String.length line - line_indent) 0) "‾")
else if line_no <> sline && line_no = eline then
Cli.with_style error_indicator_style "%*s%*s" line_indent ""
(get_end_column pos - 1 - line_indent)
(string_repeat (max (get_end_column pos - line_indent) 0) "‾")
else assert false (* should not happen *)
else ""
let match_start_index =
utf8_byte_index line
(if line_no = sline then get_start_column pos - 1 else line_indent)
in
let match_end_index =
if line_no = eline then utf8_byte_index line (get_end_column pos - 1)
else String.length line
in
let unmatched_prefix = String.sub line 0 match_start_index in
let matched_substring =
String.sub line match_start_index
(max 0 (match_end_index - match_start_index))
in
let match_start_col = string_columns unmatched_prefix in
let match_num_cols = string_columns matched_substring in
String.concat ""
(line
:: "\n"
::
(if line_no >= sline && line_no <= eline then
[
string_repeat match_start_col " ";
Cli.with_style error_indicator_style "%s"
(string_repeat match_num_cols "‾");
]
else []))
in
let include_extra_count = 0 in
let rec get_lines (n : int) : string list =
@ -193,10 +212,8 @@ let retrieve_loc_text (pos : t) : string =
(Cli.with_style blue_style "└%s┐" (string_repeat spaces "─"));
Buffer.add_char buf '\n';
Buffer.add_string buf
(Cli.add_prefix_to_each_line
(String.concat "\n" ("" :: pos_lines))
(fun i ->
let cur_line = sline - include_extra_count + i - 1 in
(Cli.add_prefix_to_each_line (String.concat "\n" pos_lines) (fun i ->
let cur_line = sline - include_extra_count + i in
if
cur_line >= sline
&& cur_line <= sline + (2 * (eline - sline))

0
compiler/utils/pos.mli → compiler/catala_utils/pos.mli
View File

26
compiler/utils/string_common.ml → compiler/catala_utils/string.ml
View File

@ -14,39 +14,41 @@
License for the specific language governing permissions and limitations under
the License. *)
let to_ascii : string -> string = Ubase.from_utf8
include Stdlib.String
let is_uppercase_ascii (c : char) : bool =
let c = Char.code c in
(* 'A' <= c && c <= 'Z' *)
0x41 <= c && c <= 0x5b
let to_ascii : string -> string = Ubase.from_utf8
let is_uppercase_ascii = function 'A' .. 'Z' -> true | _ -> false
let begins_with_uppercase (s : string) : bool =
if "" = s then false else is_uppercase_ascii (to_ascii s).[0]
"" <> s && is_uppercase_ascii (get (to_ascii s) 0)
let to_snake_case (s : string) : string =
let out = ref "" in
to_ascii s
|> String.iteri (fun i c ->
|> iteri (fun i c ->
out :=
!out
^ (if is_uppercase_ascii c && 0 <> i then "_" else "")
^ String.lowercase_ascii (String.make 1 c));
^ lowercase_ascii (make 1 c));
!out
let to_camel_case (s : string) : string =
let last_was_underscore = ref false in
let out = ref "" in
to_ascii s
|> String.iteri (fun i c ->
|> iteri (fun i c ->
let is_underscore = c = '_' in
let c_string = String.make 1 c in
let c_string = make 1 c in
out :=
!out
^
if is_underscore then ""
else if !last_was_underscore || 0 = i then
String.uppercase_ascii c_string
else if !last_was_underscore || 0 = i then uppercase_ascii c_string
else c_string;
last_was_underscore := is_underscore);
!out
let format_t = Format.pp_print_string
module Set = Set.Make (Stdlib.String)
module Map = Map.Make (Stdlib.String)

6
compiler/utils/string_common.mli → compiler/catala_utils/string.mli
View File

@ -14,6 +14,10 @@
License for the specific language governing permissions and limitations under
the License. *)
include module type of Stdlib.String
module Set : Set.S with type elt = string
module Map : Map.S with type key = string
(** Helper functions used for string manipulation. *)
val to_ascii : string -> string
@ -34,3 +38,5 @@ val to_snake_case : string -> string
val to_camel_case : string -> string
(** Converts snake_case into CamlCase after removing Remove all diacritics on
Latin letters. *)
val format_t : Format.formatter -> string -> unit

29
compiler/utils/uid.ml → compiler/catala_utils/uid.ml
View File

@ -18,7 +18,7 @@ module type Info = sig
type info
val to_string : info -> string
val format_info : Format.formatter -> info -> unit
val format : Format.formatter -> info -> unit
val equal : info -> info -> bool
val compare : info -> info -> int
end
@ -33,10 +33,21 @@ module type Id = sig
val equal : t -> t -> bool
val format_t : Format.formatter -> t -> unit
val hash : t -> int
module Set : Set.S with type elt = t
module Map : Map.S with type key = t
end
module Make (X : Info) () : Id with type info = X.info = struct
type t = { id : int; info : X.info }
module Ordering = struct
type t = { id : int; info : X.info }
let compare (x : t) (y : t) : int = compare x.id y.id
let equal x y = Int.equal x.id y.id
end
include Ordering
type info = X.info
let counter = ref 0
@ -46,20 +57,20 @@ module Make (X : Info) () : Id with type info = X.info = struct
{ id = !counter; info }
let get_info (uid : t) : X.info = uid.info
let compare (x : t) (y : t) : int = compare x.id y.id
let equal x y = Int.equal x.id y.id
let format_t (fmt : Format.formatter) (x : t) : unit =
X.format_info fmt x.info
let format_t (fmt : Format.formatter) (x : t) : unit = X.format fmt x.info
let hash (x : t) : int = x.id
module Set = Set.Make (Ordering)
module Map = Map.Make (Ordering)
end
module MarkedString = struct
type info = string Marked.pos
let to_string (s, _) = s
let format_info fmt i = Format.pp_print_string fmt (to_string i)
let format fmt i = Format.pp_print_string fmt (to_string i)
let equal i1 i2 = String.equal (Marked.unmark i1) (Marked.unmark i2)
let compare i1 i2 = String.compare (Marked.unmark i1) (Marked.unmark i2)
end
module Gen () = Make (MarkedString) ()

8
compiler/utils/uid.mli → compiler/catala_utils/uid.mli
View File

@ -21,7 +21,7 @@ module type Info = sig
type info
val to_string : info -> string
val format_info : Format.formatter -> info -> unit
val format : Format.formatter -> info -> unit
val equal : info -> info -> bool
(** Equality disregards position *)
@ -48,9 +48,15 @@ module type Id = sig
val equal : t -> t -> bool
val format_t : Format.formatter -> t -> unit
val hash : t -> int
module Set : Set.S with type elt = t
module Map : Map.S with type key = t
end
(** This is the generative functor that ensures that two modules resulting from
two different calls to [Make] will be viewed as different types [t] by the
OCaml typechecker. Prevents mixing up different sorts of identifiers. *)
module Make (X : Info) () : Id with type info = X.info
module Gen () : Id with type info = MarkedString.info
(** Shortcut for creating a kind of uids over marked strings *)

3
compiler/catala_web_interpreter.ml
View File

@ -1,3 +1,4 @@
open Catala_utils
open Driver
open Js_of_ocaml
@ -12,7 +13,7 @@ let _ =
driver
(Contents (Js.to_string contents))
{
Utils.Cli.debug = false;
Cli.debug = false;
color = Never;
wrap_weaved_output = false;
avoid_exceptions = false;

2
compiler/dcalc/dune
View File

@ -4,7 +4,7 @@
(libraries
bindlib
unionFind
utils
catala_utils
re
ubase
catala.runtime_ocaml

144
compiler/dcalc/from_scopelang.ml
View File

@ -14,7 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
open Shared_ast
type scope_var_ctx = {
@ -24,7 +24,7 @@ type scope_var_ctx = {
}
type scope_input_var_ctx = {
scope_input_name : StructFieldName.t;
scope_input_name : StructField.t;
scope_input_io : Desugared.Ast.io_input Marked.pos;
scope_input_typ : naked_typ;
}
@ -36,25 +36,26 @@ type 'm scope_sig_ctx = {
(** Var representing the scope input inside the scope func *)
scope_sig_input_struct : StructName.t; (** Scope input *)
scope_sig_output_struct : StructName.t; (** Scope output *)
scope_sig_in_fields : scope_input_var_ctx ScopeVarMap.t;
scope_sig_in_fields : scope_input_var_ctx ScopeVar.Map.t;
(** Mapping between the input scope variables and the input struct fields. *)
scope_sig_out_fields : StructFieldName.t ScopeVarMap.t;
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 ScopeMap.t
type 'm scope_sigs_ctx = 'm scope_sig_ctx ScopeName.Map.t
type 'm ctx = {
structs : struct_ctx;
enums : enum_ctx;
scope_name : ScopeName.t;
scopes_parameters : 'm scope_sigs_ctx;
scope_vars : ('m Ast.expr Var.t * naked_typ * Desugared.Ast.io) ScopeVarMap.t;
scope_vars :
('m Ast.expr Var.t * naked_typ * Desugared.Ast.io) ScopeVar.Map.t;
subscope_vars :
('m Ast.expr Var.t * naked_typ * Desugared.Ast.io) ScopeVarMap.t
SubScopeMap.t;
('m Ast.expr Var.t * naked_typ * Desugared.Ast.io) ScopeVar.Map.t
SubScopeName.Map.t;
local_vars : ('m Scopelang.Ast.expr, 'm Ast.expr Var.t) Var.Map.t;
}
@ -68,8 +69,8 @@ let empty_ctx
enums = enum_ctx;
scope_name;
scopes_parameters = scopes_ctx;
scope_vars = ScopeVarMap.empty;
subscope_vars = SubScopeMap.empty;
scope_vars = ScopeVar.Map.empty;
subscope_vars = SubScopeName.Map.empty;
local_vars = Var.Map.empty;
}
@ -149,7 +150,7 @@ let merge_defaults
let tag_with_log_entry
(e : 'm Ast.expr boxed)
(l : log_entry)
(markings : Utils.Uid.MarkedString.info list) : 'm Ast.expr boxed =
(markings : Uid.MarkedString.info list) : 'm Ast.expr boxed =
let m = mark_tany (Marked.get_mark e) (Expr.pos e) in
Expr.eapp (Expr.eop (Unop (Log (l, markings))) m) [e] m
@ -221,7 +222,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
| LDuration _ ) as l) ->
Expr.elit l m
| EStruct { name; fields } ->
let fields = StructFieldMap.map (translate_expr ctx) fields in
let fields = StructField.Map.map (translate_expr ctx) fields in
Expr.estruct name fields m
| EStructAccess { e; field; name } ->
Expr.estructaccess (translate_expr ctx e) field name m
@ -229,13 +230,13 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
let e' = translate_expr ctx e in
Expr.einj e' cons name m
| EMatch { e = e1; name; cases = e_cases } ->
let enum_sig = EnumMap.find name ctx.enums in
let enum_sig = EnumName.Map.find name ctx.enums in
let d_cases, remaining_e_cases =
(* FIXME: these checks should probably be moved to a better place *)
EnumConstructorMap.fold
EnumConstructor.Map.fold
(fun constructor _ (d_cases, e_cases) ->
let case_e =
try EnumConstructorMap.find constructor e_cases
try EnumConstructor.Map.find constructor e_cases
with Not_found ->
Errors.raise_spanned_error (Expr.pos e)
"The constructor %a of enum %a is missing from this pattern \
@ -243,26 +244,26 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
EnumConstructor.format_t constructor EnumName.format_t name
in
let case_d = translate_expr ctx case_e in
( EnumConstructorMap.add constructor case_d d_cases,
EnumConstructorMap.remove constructor e_cases ))
( EnumConstructor.Map.add constructor case_d d_cases,
EnumConstructor.Map.remove constructor e_cases ))
enum_sig
(EnumConstructorMap.empty, e_cases)
(EnumConstructor.Map.empty, e_cases)
in
if not (EnumConstructorMap.is_empty remaining_e_cases) then
if not (EnumConstructor.Map.is_empty remaining_e_cases) then
Errors.raise_spanned_error (Expr.pos e)
"Pattern matching is incomplete for enum %a: missing cases %a"
EnumName.format_t name
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
(fun fmt (case_name, _) -> EnumConstructor.format_t fmt case_name))
(EnumConstructorMap.bindings remaining_e_cases);
(EnumConstructor.Map.bindings remaining_e_cases);
let e1 = translate_expr ctx e1 in
Expr.ematch e1 name d_cases m
| EScopeCall { scope; args } ->
let pos = Expr.mark_pos m in
let sc_sig = ScopeMap.find scope ctx.scopes_parameters in
let sc_sig = ScopeName.Map.find scope ctx.scopes_parameters in
let in_var_map =
ScopeVarMap.merge
ScopeVar.Map.merge
(fun var_name (str_field : scope_input_var_ctx option) expr ->
let expr =
match str_field, expr with
@ -287,7 +288,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
None, pos;
( Some "Declaration of the missing input variable",
Marked.get_mark
(StructFieldName.get_info var_ctx.scope_input_name) );
(StructField.get_info var_ctx.scope_input_name) );
]
"Definition of input variable '%a' missing in this scope call"
ScopeVar.format_t var_name
@ -303,9 +304,9 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
sc_sig.scope_sig_in_fields args
in
let field_map =
ScopeVarMap.fold
(fun _ (fld, e) acc -> StructFieldMap.add fld e acc)
in_var_map StructFieldMap.empty
ScopeVar.Map.fold
(fun _ (fld, e) acc -> StructField.Map.add fld e acc)
in_var_map StructField.Map.empty
in
let arg_struct =
Expr.estruct sc_sig.scope_sig_input_struct field_map (mark_tany m pos)
@ -336,7 +337,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
-- for more information see
https://github.com/CatalaLang/catala/pull/280#discussion_r898851693. *)
let retrieve_in_and_out_typ_or_any var vars =
let _, typ, _ = ScopeVarMap.find (Marked.unmark var) vars in
let _, typ, _ = ScopeVar.Map.find (Marked.unmark var) vars in
match typ with
| TArrow (marked_input_typ, marked_output_typ) ->
Marked.unmark marked_input_typ, Marked.unmark marked_output_typ
@ -347,7 +348,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
retrieve_in_and_out_typ_or_any var ctx.scope_vars
| ELocation (SubScopeVar (_, sname, var)) ->
ctx.subscope_vars
|> SubScopeMap.find (Marked.unmark sname)
|> SubScopeName.Map.find (Marked.unmark sname)
|> retrieve_in_and_out_typ_or_any var
| _ -> TAny, TAny
in
@ -394,13 +395,13 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
(List.map (translate_expr ctx) excepts)
(translate_expr ctx just) (translate_expr ctx cons) m
| ELocation (ScopelangScopeVar a) ->
let v, _, _ = ScopeVarMap.find (Marked.unmark a) ctx.scope_vars in
let v, _, _ = ScopeVar.Map.find (Marked.unmark a) ctx.scope_vars in
Expr.evar v m
| ELocation (SubScopeVar (_, s, a)) -> (
try
let v, _, _ =
ScopeVarMap.find (Marked.unmark a)
(SubScopeMap.find (Marked.unmark s) ctx.subscope_vars)
ScopeVar.Map.find (Marked.unmark a)
(SubScopeName.Map.find (Marked.unmark s) ctx.subscope_vars)
in
Expr.evar v m
with Not_found ->
@ -420,7 +421,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
Expr.eifthenelse (translate_expr ctx cond) (translate_expr ctx etrue)
(translate_expr ctx efalse)
m
| EOp op -> Expr.eop op m
| EOp op -> Expr.eop (Expr.translate_op op) m
| EErrorOnEmpty e' -> Expr.eerroronempty (translate_expr ctx e') m
| EArray es -> Expr.earray (List.map (translate_expr ctx) es) m
@ -432,7 +433,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
let translate_rule
(ctx : 'm ctx)
(rule : 'm Scopelang.Ast.rule)
((sigma_name, pos_sigma) : Utils.Uid.MarkedString.info) :
((sigma_name, pos_sigma) : Uid.MarkedString.info) :
('m Ast.expr scope_body_expr Bindlib.box ->
'm Ast.expr scope_body_expr Bindlib.box)
* 'm ctx =
@ -475,7 +476,7 @@ let translate_rule
{
ctx with
scope_vars =
ScopeVarMap.add (Marked.unmark a)
ScopeVar.Map.add (Marked.unmark a)
(a_var, Marked.unmark tau, a_io)
ctx.scope_vars;
} )
@ -524,22 +525,22 @@ let translate_rule
{
ctx with
subscope_vars =
SubScopeMap.update (Marked.unmark subs_index)
SubScopeName.Map.update (Marked.unmark subs_index)
(fun map ->
match map with
| Some map ->
Some
(ScopeVarMap.add (Marked.unmark subs_var)
(ScopeVar.Map.add (Marked.unmark subs_var)
(a_var, Marked.unmark tau, a_io)
map)
| None ->
Some
(ScopeVarMap.singleton (Marked.unmark subs_var)
(ScopeVar.Map.singleton (Marked.unmark subs_var)
(a_var, Marked.unmark tau, a_io)))
ctx.subscope_vars;
} )
| Call (subname, subindex, m) ->
let subscope_sig = ScopeMap.find subname ctx.scopes_parameters in
let subscope_sig = ScopeName.Map.find subname ctx.scopes_parameters in
let all_subscope_vars = subscope_sig.scope_sig_local_vars in
let all_subscope_input_vars =
List.filter
@ -559,11 +560,11 @@ let translate_rule
let called_scope_input_struct = subscope_sig.scope_sig_input_struct in
let called_scope_return_struct = subscope_sig.scope_sig_output_struct in
let subscope_vars_defined =
try SubScopeMap.find subindex ctx.subscope_vars
with Not_found -> ScopeVarMap.empty
try SubScopeName.Map.find subindex ctx.subscope_vars
with Not_found -> ScopeVar.Map.empty
in
let subscope_var_not_yet_defined subvar =
not (ScopeVarMap.mem subvar subscope_vars_defined)
not (ScopeVar.Map.mem subvar subscope_vars_defined)
in
let pos_call = Marked.get_mark (SubScopeName.get_info subindex) in
let subscope_args =
@ -578,17 +579,17 @@ let translate_rule
Expr.empty_thunked_term m
else
let a_var, _, _ =
ScopeVarMap.find subvar.scope_var_name subscope_vars_defined
ScopeVar.Map.find subvar.scope_var_name subscope_vars_defined
in
Expr.make_var a_var (mark_tany m pos_call)
in
let field =
(ScopeVarMap.find subvar.scope_var_name
(ScopeVar.Map.find subvar.scope_var_name
subscope_sig.scope_sig_in_fields)
.scope_input_name
in
StructFieldMap.add field e acc)
StructFieldMap.empty all_subscope_input_vars
StructField.Map.add field e acc)
StructField.Map.empty all_subscope_input_vars
in
let subscope_struct_arg =
Expr.estruct called_scope_input_struct subscope_args
@ -646,7 +647,7 @@ let translate_rule
List.fold_right
(fun (var_ctx, v) next ->
let field =
ScopeVarMap.find var_ctx.scope_var_name
ScopeVar.Map.find var_ctx.scope_var_name
subscope_sig.scope_sig_out_fields
in
Bindlib.box_apply2
@ -671,13 +672,13 @@ let translate_rule
{
ctx with
subscope_vars =
SubScopeMap.add subindex
SubScopeName.Map.add subindex
(List.fold_left
(fun acc (var_ctx, dvar) ->
ScopeVarMap.add var_ctx.scope_var_name
ScopeVar.Map.add var_ctx.scope_var_name
(dvar, var_ctx.scope_var_typ, var_ctx.scope_var_io)
acc)
ScopeVarMap.empty all_subscope_output_vars_dcalc)
ScopeVar.Map.empty all_subscope_output_vars_dcalc)
ctx.subscope_vars;
} )
| Assertion e ->
@ -707,7 +708,7 @@ let translate_rule
let translate_rules
(ctx : 'm ctx)
(rules : 'm Scopelang.Ast.rule list)
((sigma_name, pos_sigma) : Utils.Uid.MarkedString.info)
((sigma_name, pos_sigma) : Uid.MarkedString.info)
(mark : 'm mark)
(scope_sig : 'm scope_sig_ctx) :
'm Ast.expr scope_body_expr Bindlib.box * 'm ctx =
@ -723,15 +724,15 @@ let translate_rules
in
let return_exp =
Expr.estruct scope_sig.scope_sig_output_struct
(ScopeVarMap.fold
(ScopeVar.Map.fold
(fun var (dcalc_var, _, io) acc ->
if Marked.unmark io.Desugared.Ast.io_output then
let field = ScopeVarMap.find var scope_sig.scope_sig_out_fields in
StructFieldMap.add field
let field = ScopeVar.Map.find var scope_sig.scope_sig_out_fields in
StructField.Map.add field
(Expr.make_var dcalc_var (mark_tany mark pos_sigma))
acc
else acc)
new_ctx.scope_vars StructFieldMap.empty)
new_ctx.scope_vars StructField.Map.empty)
(mark_tany mark pos_sigma)
in
( scope_lets
@ -748,7 +749,7 @@ let translate_scope_decl
(sigma : 'm Scopelang.Ast.scope_decl) :
'm Ast.expr scope_body Bindlib.box * struct_ctx =
let sigma_info = ScopeName.get_info sigma.scope_decl_name in
let scope_sig = ScopeMap.find sigma.scope_decl_name sctx in
let scope_sig = ScopeName.Map.find sigma.scope_decl_name sctx in
let scope_variables = scope_sig.scope_sig_local_vars in
let ctx =
(* the context must be initialized for fresh variables for all only-input
@ -762,7 +763,7 @@ let translate_scope_decl
{
ctx with
scope_vars =
ScopeVarMap.add scope_var.scope_var_name
ScopeVar.Map.add scope_var.scope_var_name
( scope_var_dcalc,
scope_var.scope_var_typ,
scope_var.scope_var_io )
@ -784,7 +785,7 @@ let translate_scope_decl
List.map
(fun var_ctx ->
let dcalc_x, _, _ =
ScopeVarMap.find var_ctx.scope_var_name ctx.scope_vars
ScopeVar.Map.find var_ctx.scope_var_name ctx.scope_vars
in
var_ctx, dcalc_x)
scope_variables
@ -813,7 +814,8 @@ let translate_scope_decl
List.fold_right
(fun (var_ctx, v) next ->
let field =
(ScopeVarMap.find var_ctx.scope_var_name scope_sig.scope_sig_in_fields)
(ScopeVar.Map.find var_ctx.scope_var_name
scope_sig.scope_sig_in_fields)
.scope_input_name
in
Bindlib.box_apply2
@ -840,12 +842,14 @@ let translate_scope_decl
(fun acc (var_ctx, _) ->
let var = var_ctx.scope_var_name in
let field =
(ScopeVarMap.find var scope_sig.scope_sig_in_fields).scope_input_name
(ScopeVar.Map.find var scope_sig.scope_sig_in_fields).scope_input_name
in
StructFieldMap.add field (input_var_typ var_ctx) acc)
StructFieldMap.empty scope_input_variables
StructField.Map.add field (input_var_typ var_ctx) acc)
StructField.Map.empty scope_input_variables
in
let new_struct_ctx =
StructName.Map.singleton scope_input_struct_name field_map
in
let new_struct_ctx = StructMap.singleton scope_input_struct_name field_map in
( Bindlib.box_apply
(fun scope_body_expr ->
{
@ -865,14 +869,14 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
in
let decl_ctx = prgm.program_ctx in
let sctx : 'm scope_sigs_ctx =
ScopeMap.mapi
ScopeName.Map.mapi
(fun scope_name scope ->
let scope_dvar =
Var.make
(Marked.unmark
(ScopeName.get_info scope.Scopelang.Ast.scope_decl_name))
in
let scope_return = ScopeMap.find scope_name decl_ctx.ctx_scopes in
let scope_return = ScopeName.Map.find scope_name decl_ctx.ctx_scopes in
let scope_input_var =
Var.make (Marked.unmark (ScopeName.get_info scope_name) ^ "_in")
in
@ -883,7 +887,7 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
(ScopeName.get_info scope_name))
in
let scope_sig_in_fields =
ScopeVarMap.filter_map
ScopeVar.Map.filter_map
(fun dvar (typ, vis) ->
match Marked.unmark vis.Desugared.Ast.io_input with
| NoInput -> None
@ -893,7 +897,7 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
Some
{
scope_input_name =
StructFieldName.fresh (s, Marked.get_mark info);
StructField.fresh (s, Marked.get_mark info);
scope_input_io = vis.Desugared.Ast.io_input;
scope_input_typ = Marked.unmark typ;
})
@ -908,7 +912,7 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
scope_var_typ = Marked.unmark tau;
scope_var_io = vis;
})
(ScopeVarMap.bindings scope.scope_sig);
(ScopeVar.Map.bindings scope.scope_sig);
scope_sig_scope_var = scope_dvar;
scope_sig_input_var = scope_input_var;
scope_sig_input_struct = scope_input_struct_name;
@ -923,17 +927,17 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
order, then the chained scopes aggregated from the right. *)
let rec translate_scopes decl_ctx = function
| scope_name :: next_scopes ->
let scope = ScopeMap.find scope_name prgm.program_scopes in
let scope = ScopeName.Map.find scope_name prgm.program_scopes in
let scope_body, scope_in_struct =
translate_scope_decl decl_ctx.ctx_structs decl_ctx.ctx_enums sctx
scope_name scope
in
let dvar = (ScopeMap.find scope_name sctx).scope_sig_scope_var in
let dvar = (ScopeName.Map.find scope_name sctx).scope_sig_scope_var in
let decl_ctx =
{
decl_ctx with
ctx_structs =
StructMap.union
StructName.Map.union
(fun _ _ -> assert false (* should not happen *))
decl_ctx.ctx_structs scope_in_struct;
}

24
compiler/dcalc/interpreter.ml
View File

@ -16,7 +16,7 @@
(** Reference interpreter for the default calculus *)
open Utils
open Catala_utils
open Shared_ast
module Runtime = Runtime_ocaml.Runtime
@ -31,7 +31,7 @@ let log_indent = ref 0
let rec evaluate_operator
(ctx : decl_ctx)
(op : operator)
(op : dcalc operator)
(pos : Pos.t)
(args : 'm Ast.expr list) : 'm Ast.naked_expr =
(* Try to apply [div] and if a [Division_by_zero] exceptions is catched, use
@ -180,7 +180,7 @@ let rec evaluate_operator
ELit
(LBool
(StructName.equal s1 s2
&& StructFieldMap.equal
&& StructField.Map.equal
(fun e1 e2 ->
match evaluate_operator ctx op pos [e1; e2] with
| ELit (LBool b) -> b
@ -342,8 +342,8 @@ and evaluate_expr (ctx : decl_ctx) (e : 'm Ast.expr) : 'm Ast.expr =
happen if the term was well-typed")
| EAbs _ | ELit _ | EOp _ -> e (* these are values *)
| EStruct { fields = es; name } ->
let new_es = StructFieldMap.map (evaluate_expr ctx) es in
if StructFieldMap.exists (fun _ e -> is_empty_error e) new_es then
let new_es = StructField.Map.map (evaluate_expr ctx) es in
if StructField.Map.exists (fun _ e -> is_empty_error e) new_es then
Marked.same_mark_as (ELit LEmptyError) e
else Marked.same_mark_as (EStruct { fields = new_es; name }) e
| EStructAccess { e = e1; name = s; field } -> (
@ -355,13 +355,13 @@ and evaluate_expr (ctx : decl_ctx) (e : 'm Ast.expr) : 'm Ast.expr =
[None, Expr.pos e; None, Expr.pos e1]
"Error during struct access: not the same structs (should not happen \
if the term was well-typed)";
match StructFieldMap.find_opt field es with
match StructField.Map.find_opt field es with
| Some e' -> e'
| None ->
Errors.raise_spanned_error (Expr.pos e1)
"Invalid field access %a in struct %a (should not happen if the term \
was well-typed)"
StructFieldName.format_t field StructName.format_t s)
StructField.format_t field StructName.format_t s)
| ELit LEmptyError -> Marked.same_mark_as (ELit LEmptyError) e
| _ ->
Errors.raise_spanned_error (Expr.pos e1)
@ -383,7 +383,7 @@ and evaluate_expr (ctx : decl_ctx) (e : 'm Ast.expr) : 'm Ast.expr =
"Error during match: two different enums found (should not happen if \
the term was well-typed)";
let es_n =
match EnumConstructorMap.find_opt cons es with
match EnumConstructor.Map.find_opt cons es with
| Some es_n -> es_n
| None ->
Errors.raise_spanned_error (Expr.pos e)
@ -499,9 +499,9 @@ let interpret_program :
the types of the scope arguments. For [context] arguments, we can provide
an empty thunked term. But for [input] arguments of another type, we
cannot provide anything so we have to fail. *)
let taus = StructMap.find s_in ctx.ctx_structs in
let taus = StructName.Map.find s_in ctx.ctx_structs in
let application_term =
StructFieldMap.map
StructField.Map.map
(fun ty ->
match Marked.unmark ty with
| TArrow (ty_in, ty_out) ->
@ -526,8 +526,8 @@ let interpret_program :
match Marked.unmark (evaluate_expr ctx (Expr.unbox to_interpret)) with
| EStruct { fields; _ } ->
List.map
(fun (fld, e) -> StructFieldName.get_info fld, e)
(StructFieldMap.bindings fields)
(fun (fld, e) -> StructField.get_info fld, e)
(StructField.Map.bindings fields)
| _ ->
Errors.raise_spanned_error (Expr.pos e)
"The interpretation of a program should always yield a struct \

2
compiler/dcalc/interpreter.mli
View File

@ -16,7 +16,7 @@
(** Reference interpreter for the default calculus *)
open Utils
open Catala_utils
open Shared_ast
val evaluate_expr : decl_ctx -> 'm Ast.expr -> 'm Ast.expr

4
compiler/dcalc/optimizations.ml
View File

@ -14,7 +14,7 @@
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 Utils
open Catala_utils
open Shared_ast
open Ast
@ -80,7 +80,7 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : 'm expr) :
| EMatch { e = EInj { e; name = name1; cons }, _; cases; name }
when EnumName.equal name name1 ->
(* iota reduction *)
EApp { f = EnumConstructorMap.find cons cases; args = [e] }
EApp { f = EnumConstructor.Map.find cons cases; args = [e] }
| EApp { f = EAbs { binder; _ }, _; args } ->
(* beta reduction *)
Marked.unmark (Bindlib.msubst binder (List.map fst args |> Array.of_list))

17
compiler/desugared/ast.ml
View File

@ -16,7 +16,7 @@
(** Abstract syntax tree of the desugared representation *)
open Utils
open Catala_utils
open Shared_ast
(** {1 Names, Maps and Keys} *)
@ -178,7 +178,7 @@ type meta_assertion =
| VariesWith of unit * variation_typ Marked.pos option
type scope_def = {
scope_def_rules : rule RuleMap.t;
scope_def_rules : rule RuleName.Map.t;
scope_def_typ : typ;
scope_def_is_condition : bool;
scope_def_io : io;
@ -187,15 +187,18 @@ type scope_def = {
type var_or_states = WholeVar | States of StateName.t list
type scope = {
scope_vars : var_or_states ScopeVarMap.t;
scope_sub_scopes : ScopeName.t SubScopeMap.t;
scope_vars : var_or_states ScopeVar.Map.t;
scope_sub_scopes : ScopeName.t SubScopeName.Map.t;
scope_uid : ScopeName.t;
scope_defs : scope_def ScopeDefMap.t;
scope_assertions : assertion list;
scope_meta_assertions : meta_assertion list;
}
type program = { program_scopes : scope ScopeMap.t; program_ctx : decl_ctx }
type program = {
program_scopes : scope ScopeName.Map.t;
program_ctx : decl_ctx;
}
let rec locations_used e : LocationSet.t =
match e with
@ -208,7 +211,7 @@ let rec locations_used e : LocationSet.t =
(fun e -> LocationSet.union (locations_used e))
e LocationSet.empty
let free_variables (def : rule RuleMap.t) : Pos.t ScopeDefMap.t =
let free_variables (def : rule RuleName.Map.t) : Pos.t ScopeDefMap.t =
let add_locs (acc : Pos.t ScopeDefMap.t) (locs : LocationSet.t) :
Pos.t ScopeDefMap.t =
LocationSet.fold
@ -224,7 +227,7 @@ let free_variables (def : rule RuleMap.t) : Pos.t ScopeDefMap.t =
loc_pos acc)
locs acc
in
RuleMap.fold
RuleName.Map.fold
(fun _ rule acc ->
let locs =
LocationSet.union

15
compiler/desugared/ast.mli
View File

@ -16,7 +16,7 @@
(** Abstract syntax tree of the desugared representation *)
open Utils
open Catala_utils
open Shared_ast
(** Inside a scope, a definition can refer either to a scope def, or a subscope
@ -100,7 +100,7 @@ type io = {
(** Characterization of the input/output status of a scope variable. *)
type scope_def = {
scope_def_rules : rule RuleMap.t;
scope_def_rules : rule RuleName.Map.t;
scope_def_typ : typ;
scope_def_is_condition : bool;
scope_def_io : io;
@ -109,17 +109,20 @@ type scope_def = {
type var_or_states = WholeVar | States of StateName.t list
type scope = {
scope_vars : var_or_states ScopeVarMap.t;
scope_sub_scopes : ScopeName.t SubScopeMap.t;
scope_vars : var_or_states ScopeVar.Map.t;
scope_sub_scopes : ScopeName.t SubScopeName.Map.t;
scope_uid : ScopeName.t;
scope_defs : scope_def ScopeDefMap.t;
scope_assertions : assertion list;
scope_meta_assertions : meta_assertion list;
}
type program = { program_scopes : scope ScopeMap.t; program_ctx : decl_ctx }
type program = {
program_scopes : scope ScopeName.Map.t;
program_ctx : decl_ctx;
}
(** {1 Helpers} *)
val locations_used : expr -> LocationSet.t
val free_variables : rule RuleMap.t -> Pos.t ScopeDefMap.t
val free_variables : rule RuleName.Map.t -> Pos.t ScopeDefMap.t

70
compiler/desugared/dependency.ml
View File

@ -17,7 +17,7 @@
(** Scope dependencies computations using {{:http://ocamlgraph.lri.fr/}
OCamlgraph} *)
open Utils
open Catala_utils
open Shared_ast
(** {1 Scope variables dependency graph} *)
@ -143,7 +143,7 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
let g = ScopeDependencies.empty in
(* Add all the vertices to the graph *)
let g =
ScopeVarMap.fold
ScopeVar.Map.fold
(fun (v : ScopeVar.t) var_or_state g ->
match var_or_state with
| Ast.WholeVar -> ScopeDependencies.add_vertex g (Vertex.Var (v, None))
@ -155,7 +155,7 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
scope.scope_vars g
in
let g =
SubScopeMap.fold
SubScopeName.Map.fold
(fun (v : SubScopeName.t) _ g ->
ScopeDependencies.add_vertex g (Vertex.SubScope v))
scope.scope_sub_scopes g
@ -229,10 +229,10 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
(** {2 Graph declaration} *)
module ExceptionVertex = struct
include RuleSet
include RuleName.Set
let hash (x : t) : int =
RuleSet.fold (fun r acc -> Int.logxor (RuleName.hash r) acc) x 0
RuleName.Set.fold (fun r acc -> Int.logxor (RuleName.hash r) acc) x 0
let equal x y = compare x y = 0
end
@ -263,7 +263,7 @@ type exception_edge = {
}
let build_exceptions_graph
(def : Ast.rule RuleMap.t)
(def : Ast.rule RuleName.Map.t)
(def_info : Ast.ScopeDef.t) : ExceptionsDependencies.t =
(* First we partition the definitions into groups bearing the same label. To
handle the rules that were not labeled by the user, we create implicit
@ -275,53 +275,55 @@ let build_exceptions_graph
(* When declaring [exception definition x ...], it means there is a unique
rule [R] to which this can be an exception to. So we give a unique label to
all the rules that are implicitly exceptions to rule [R]. *)
let exception_to_rule_implicit_labels : LabelName.t RuleMap.t =
RuleMap.fold
let exception_to_rule_implicit_labels : LabelName.t RuleName.Map.t =
RuleName.Map.fold
(fun _ rule_from exception_to_rule_implicit_labels ->
match rule_from.Ast.rule_exception with
| Ast.ExceptionToRule (rule_to, _) -> (
match RuleMap.find_opt rule_to exception_to_rule_implicit_labels with
match
RuleName.Map.find_opt rule_to exception_to_rule_implicit_labels
with
| Some _ ->
(* we already created the label *) exception_to_rule_implicit_labels
| None ->
RuleMap.add rule_to
RuleName.Map.add rule_to
(LabelName.fresh
( "exception_to_" ^ Marked.unmark (RuleName.get_info rule_to),
Pos.no_pos ))
exception_to_rule_implicit_labels)
| _ -> exception_to_rule_implicit_labels)
def RuleMap.empty
def RuleName.Map.empty
in
(* When declaring [exception foo_l definition x ...], the rule is exception to
all the rules sharing label [foo_l]. So we give a unique label to all the
rules that are implicitly exceptions to rule [foo_l]. *)
let exception_to_label_implicit_labels : LabelName.t LabelMap.t =
RuleMap.fold
let exception_to_label_implicit_labels : LabelName.t LabelName.Map.t =
RuleName.Map.fold
(fun _ rule_from
(exception_to_label_implicit_labels : LabelName.t LabelMap.t) ->
(exception_to_label_implicit_labels : LabelName.t LabelName.Map.t) ->
match rule_from.Ast.rule_exception with
| Ast.ExceptionToLabel (label_to, _) -> (
match
LabelMap.find_opt label_to exception_to_label_implicit_labels
LabelName.Map.find_opt label_to exception_to_label_implicit_labels
with
| Some _ ->
(* we already created the label *)
exception_to_label_implicit_labels
| None ->
LabelMap.add label_to
LabelName.Map.add label_to
(LabelName.fresh
( "exception_to_" ^ Marked.unmark (LabelName.get_info label_to),
Pos.no_pos ))
exception_to_label_implicit_labels)
| _ -> exception_to_label_implicit_labels)
def LabelMap.empty
def LabelName.Map.empty
in
(* Now we have all the labels necessary to partition our rules into sets, each
one corresponding to a label relating to the structure of the exception
DAG. *)
let label_to_rule_sets =
RuleMap.fold
RuleName.Map.fold
(fun rule_name rule rule_sets ->
let label_of_rule =
match rule.Ast.rule_label with
@ -330,23 +332,23 @@ let build_exceptions_graph
match rule.Ast.rule_exception with
| BaseCase -> base_case_implicit_label
| ExceptionToRule (r, _) ->
RuleMap.find r exception_to_rule_implicit_labels
RuleName.Map.find r exception_to_rule_implicit_labels
| ExceptionToLabel (l', _) ->
LabelMap.find l' exception_to_label_implicit_labels)
LabelName.Map.find l' exception_to_label_implicit_labels)
in
LabelMap.update label_of_rule
LabelName.Map.update label_of_rule
(fun rule_set ->
match rule_set with
| None -> Some (RuleSet.singleton rule_name)
| Some rule_set -> Some (RuleSet.add rule_name rule_set))
| None -> Some (RuleName.Set.singleton rule_name)
| Some rule_set -> Some (RuleName.Set.add rule_name rule_set))
rule_sets)
def LabelMap.empty
def LabelName.Map.empty
in
let find_label_of_rule (r : RuleName.t) : LabelName.t =
fst
(LabelMap.choose
(LabelMap.filter
(fun _ rule_set -> RuleSet.mem r rule_set)
(LabelName.Map.choose
(LabelName.Map.filter
(fun _ rule_set -> RuleName.Set.mem r rule_set)
label_to_rule_sets))
in
(* Next, we collect the exception edges between those groups of rules referred
@ -354,7 +356,7 @@ let build_exceptions_graph
edges as they are declared at each rule but should be the same for all the
rules of the same group. *)
let exception_edges : exception_edge list =
RuleMap.fold
RuleName.Map.fold
(fun rule_name rule exception_edges ->
let label_from = find_label_of_rule rule_name in
let label_to_and_pos =
@ -414,7 +416,7 @@ let build_exceptions_graph
in
(* We've got the vertices and the edges, let's build the graph! *)
let g =
LabelMap.fold
LabelName.Map.fold
(fun _label rule_set g -> ExceptionsDependencies.add_vertex g rule_set)
label_to_rule_sets ExceptionsDependencies.empty
in
@ -423,9 +425,11 @@ let build_exceptions_graph
List.fold_left
(fun g edge ->
let rule_group_from =
LabelMap.find edge.label_from label_to_rule_sets
LabelName.Map.find edge.label_from label_to_rule_sets
in
let rule_group_to =
LabelName.Map.find edge.label_to label_to_rule_sets
in
let rule_group_to = LabelMap.find edge.label_to label_to_rule_sets in
let edge =
ExceptionsDependencies.E.create rule_group_from edge.edge_positions
rule_group_to
@ -445,8 +449,8 @@ let check_for_exception_cycle (g : ExceptionsDependencies.t) : unit =
let spans =
List.flatten
(List.map
(fun (vs : RuleSet.t) ->
let v = RuleSet.choose vs in
(fun (vs : RuleName.Set.t) ->
let v = RuleName.Set.choose vs in
let var_str, var_info =
Format.asprintf "%a" RuleName.format_t v, RuleName.get_info v
in

6
compiler/desugared/dependency.mli
View File

@ -17,7 +17,7 @@
(** Scope dependencies computations using {{:http://ocamlgraph.lri.fr/}
OCamlgraph} *)
open Utils
open Catala_utils
open Shared_ast
(** {1 Scope variables dependency graph} *)
@ -72,9 +72,9 @@ val build_scope_dependencies : Ast.scope -> ScopeDependencies.t
module EdgeExceptions : Graph.Sig.ORDERED_TYPE_DFT with type t = Pos.t list
module ExceptionsDependencies :
Graph.Sig.P with type V.t = RuleSet.t and type E.label = EdgeExceptions.t
Graph.Sig.P with type V.t = RuleName.Set.t and type E.label = EdgeExceptions.t
val build_exceptions_graph :
Ast.rule RuleMap.t -> Ast.ScopeDef.t -> ExceptionsDependencies.t
Ast.rule RuleName.Map.t -> Ast.ScopeDef.t -> ExceptionsDependencies.t
val check_for_exception_cycle : ExceptionsDependencies.t -> unit

78
compiler/desugared/disambiguate.ml Normal file
View File

@ -0,0 +1,78 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
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 Shared_ast
open Ast
let expr ctx env e =
(* The typer takes care of disambiguating: this consists in: - ensuring
[EAbs.tys] doesn't contain any [TAny] - [EDStructAccess.name_opt] is always
[Some] *)
(* Intermediate unboxings are fine since the last [untype] will rebox in
depth *)
Typing.check_expr ctx ~env (Expr.unbox e)
let rule ctx env rule =
let env =
match rule.rule_parameter with
| None -> env
| Some (v, ty) -> Typing.Env.add_var v ty env
in
(* Note: we could use the known rule type here to direct typing. We choose not
to because it shouldn't be needed for disambiguation, and we prefer to
focus on local type errors first. *)
{
rule with
rule_just = expr ctx env rule.rule_just;
rule_cons = expr ctx env rule.rule_cons;
}
let scope ctx env scope =
let env = Typing.Env.open_scope scope.scope_uid env in
let scope_defs =
ScopeDefMap.map
(fun def ->
let scope_def_rules =
(* Note: ordering in file order might be better for error reporting ?
When we gather errors, the ordering could be done afterwards,
though *)
RuleName.Map.map (rule ctx env) def.scope_def_rules
in
{ def with scope_def_rules })
scope.scope_defs
in
let scope_assertions = List.map (expr ctx env) scope.scope_assertions in
{ scope with scope_defs; scope_assertions }
let program prg =
let env =
ScopeName.Map.fold
(fun scope_name scope env ->
let vars =
ScopeDefMap.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 Typing.Env.empty
in
let program_scopes =
ScopeName.Map.map (scope prg.program_ctx env) prg.program_scopes
in
{ prg with program_scopes }

24
compiler/desugared/disambiguate.mli Normal file
View File

@ -0,0 +1,24 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
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 does local typing in order to fill some missing type information
in the AST:
- it fills the types of arguments in [EAbs] nodes, (untyped ones are
inserted during desugaring, e.g. by `let-in` constructs),
- it resolves the structure names of [EDStructAccess] nodes. *)
val program : Ast.program -> Ast.program

2
compiler/desugared/dune
View File

@ -1,7 +1,7 @@
(library
(name desugared)
(public_name catala.desugared)
(libraries ocamlgraph utils shared_ast surface))
(libraries ocamlgraph catala_utils shared_ast surface))
(documentation
(package catala)

247
compiler/desugared/from_surface.ml
View File

@ -15,7 +15,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
module SurfacePrint = Surface.Print
open Shared_ast
module Runtime = Runtime_ocaml.Runtime
@ -27,15 +27,15 @@ module Runtime = Runtime_ocaml.Runtime
(** {1 Translating expressions} *)
let translate_op_kind (k : Surface.Ast.op_kind) : op_kind =
let translate_op_kind (k : Surface.Ast.op_kind) : desugared op_kind =
match k with
| KInt -> KInt
| KDec -> KRat
| KMoney -> KMoney
| KDate -> KDate
| KDuration -> KDuration
| Surface.Ast.KInt -> KInt
| Surface.Ast.KDec -> KRat
| Surface.Ast.KMoney -> KMoney
| Surface.Ast.KDate -> KDate
| Surface.Ast.KDuration -> KDuration
let translate_binop (op : Surface.Ast.binop) : binop =
let translate_binop (op : Surface.Ast.binop) : desugared binop =
match op with
| And -> And
| Or -> Or
@ -52,7 +52,7 @@ let translate_binop (op : Surface.Ast.binop) : binop =
| Neq -> Neq
| Concat -> Concat
let translate_unop (op : Surface.Ast.unop) : unop =
let translate_unop (op : Surface.Ast.unop) : desugared unop =
match op with Not -> Not | Minus l -> Minus (translate_op_kind l)
let disambiguate_constructor
@ -67,10 +67,7 @@ let disambiguate_constructor
"The deep pattern matching syntactic sugar is not yet supported"
in
let possible_c_uids =
try
Name_resolution.IdentMap.find
(Marked.unmark constructor)
ctxt.constructor_idmap
try IdentName.Map.find (Marked.unmark constructor) ctxt.constructor_idmap
with Not_found ->
Errors.raise_spanned_error
(Marked.get_mark constructor)
@ -79,7 +76,7 @@ let disambiguate_constructor
in
match enum with
| None ->
if EnumMap.cardinal possible_c_uids > 1 then
if EnumName.Map.cardinal possible_c_uids > 1 then
Errors.raise_spanned_error
(Marked.get_mark constructor)
"This constructor name is ambiguous, it can belong to %a. Disambiguate \
@ -88,14 +85,14 @@ let disambiguate_constructor
~pp_sep:(fun fmt () -> Format.fprintf fmt " or ")
(fun fmt (s_name, _) ->
Format.fprintf fmt "%a" EnumName.format_t s_name))
(EnumMap.bindings possible_c_uids);
EnumMap.choose possible_c_uids
(EnumName.Map.bindings possible_c_uids);
EnumName.Map.choose possible_c_uids
| Some enum -> (
try
(* The path is fully qualified *)
let e_uid = Name_resolution.get_enum ctxt enum in
try
let c_uid = EnumMap.find e_uid possible_c_uids in
let c_uid = EnumName.Map.find e_uid possible_c_uids in
e_uid, c_uid
with Not_found ->
Errors.raise_spanned_error pos "Enum %s does not contain case %s"
@ -114,7 +111,7 @@ let rec translate_expr
(inside_definition_of : Ast.ScopeDef.t Marked.pos option)
(ctxt : Name_resolution.context)
(expr : Surface.Ast.expression Marked.pos) : Ast.expr boxed =
let scope_ctxt = ScopeMap.find scope ctxt.scopes in
let scope_ctxt = ScopeName.Map.find scope ctxt.scopes in
let rec_helper = translate_expr scope inside_definition_of ctxt in
let pos = Marked.get_mark expr in
let emark = Untyped { pos } in
@ -130,7 +127,7 @@ let rec translate_expr
disambiguate_constructor ctxt constructors pos_pattern
in
let cases =
EnumConstructorMap.mapi
EnumConstructor.Map.mapi
(fun c_uid' tau ->
if EnumConstructor.compare c_uid c_uid' <> 0 then
let nop_var = Var.make "_" in
@ -143,7 +140,7 @@ let rec translate_expr
in
let e2 = translate_expr scope inside_definition_of ctxt e2 in
Expr.make_abs [| binding_var |] e2 [tau] pos)
(EnumMap.find enum_uid ctxt.enums)
(EnumName.Map.find enum_uid ctxt.enums)
in
Expr.ematch
(translate_expr scope inside_definition_of ctxt e1_sub)
@ -204,15 +201,15 @@ let rec translate_expr
| Ident x -> (
(* first we check whether this is a local var, then we resort to scope-wide
variables *)
match Name_resolution.IdentMap.find_opt x ctxt.local_var_idmap with
match IdentName.Map.find_opt x ctxt.local_var_idmap with
| None -> (
match Name_resolution.IdentMap.find_opt x scope_ctxt.var_idmap with
match IdentName.Map.find_opt x scope_ctxt.var_idmap with
| Some (ScopeVar uid) ->
(* If the referenced variable has states, then here are the rules to
desambiguate. In general, only the last state can be referenced.
Except if defining a state of the same variable, then it references
the previous state in the chain. *)
let x_sig = ScopeVarMap.find uid ctxt.var_typs in
let x_sig = ScopeVar.Map.find uid ctxt.var_typs in
let x_state =
match x_sig.var_sig_states_list with
| [] -> None
@ -258,7 +255,7 @@ let rec translate_expr
| Ident y when Name_resolution.is_subscope_uid scope ctxt y ->
(* In this case, y.x is a subscope variable *)
let subscope_uid, subscope_real_uid =
match Name_resolution.IdentMap.find y scope_ctxt.var_idmap with
match IdentName.Map.find y scope_ctxt.var_idmap with
| SubScope (sub, sc) -> sub, sc
| ScopeVar _ -> assert false
in
@ -269,53 +266,29 @@ let rec translate_expr
(SubScopeVar
(subscope_real_uid, (subscope_uid, pos), (subscope_var_uid, pos)))
emark
| _ -> (
| _ ->
(* In this case e.x is the struct field x access of expression e *)
let e = translate_expr scope inside_definition_of ctxt e in
let x_possible_structs =
try Name_resolution.IdentMap.find (Marked.unmark x) ctxt.field_idmap
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark x)
"Unknown subscope or struct field name"
let str =
Option.map
(fun c ->
try Name_resolution.get_struct ctxt c
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark c)
"Struct %s has not been defined before" (Marked.unmark c))
c
in
match c with
| None ->
(* No constructor name was specified *)
if StructMap.cardinal x_possible_structs > 1 then
Errors.raise_spanned_error (Marked.get_mark x)
"This struct field name is ambiguous, it can belong to %a. \
Disambiguate it by prefixing it with the struct name."
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " or ")
(fun fmt (s_name, _) ->
Format.fprintf fmt "%a" StructName.format_t s_name))
(StructMap.bindings x_possible_structs)
else
let s_uid, f_uid = StructMap.choose x_possible_structs in
Expr.estructaccess e f_uid s_uid emark
| Some c_name -> (
try
let c_uid = Name_resolution.get_struct ctxt c_name in
try
let f_uid = StructMap.find c_uid x_possible_structs in
Expr.estructaccess e f_uid c_uid emark
with Not_found ->
Errors.raise_spanned_error pos "Struct %s does not contain field %s"
(Marked.unmark c_name) (Marked.unmark x)
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark c_name)
"Struct %s has not been defined before" (Marked.unmark c_name))))
Expr.edstructaccess e (Marked.unmark x) str emark)
| FunCall (f, arg) -> Expr.eapp (rec_helper f) [rec_helper arg] emark
| ScopeCall (sc_name, fields) ->
let called_scope = Name_resolution.get_scope ctxt sc_name in
let scope_def = ScopeMap.find called_scope ctxt.scopes in
let scope_def = ScopeName.Map.find called_scope ctxt.scopes in
let in_struct =
List.fold_left
(fun acc (fld_id, e) ->
let var =
match
Name_resolution.IdentMap.find_opt (Marked.unmark fld_id)
scope_def.var_idmap
IdentName.Map.find_opt (Marked.unmark fld_id) scope_def.var_idmap
with
| Some (ScopeVar v) -> v
| Some (SubScope _) | None ->
@ -330,7 +303,7 @@ let rec translate_expr
"Scope %a has no input variable %a" ScopeName.format_t
called_scope Print.lit_style (Marked.unmark fld_id)
in
ScopeVarMap.update var
ScopeVar.Map.update var
(function
| None -> Some (rec_helper e)
| Some _ ->
@ -338,12 +311,13 @@ let rec translate_expr
"Duplicate definition of scope input variable '%a'"
ScopeVar.format_t var)
acc)
ScopeVarMap.empty fields
ScopeVar.Map.empty fields
in
Expr.escopecall called_scope in_struct emark
| LetIn (x, e1, e2) ->
let ctxt, v = Name_resolution.add_def_local_var ctxt (Marked.unmark x) in
let tau = TAny, Marked.get_mark x in
(* This type will be resolved in Scopelang.Desambiguation *)
let fn =
Expr.make_abs [| v |]
(translate_expr scope inside_definition_of ctxt e2)
@ -352,9 +326,7 @@ let rec translate_expr
Expr.eapp fn [rec_helper e1] emark
| StructLit (s_name, fields) ->
let s_uid =
match
Name_resolution.IdentMap.find_opt (Marked.unmark s_name) ctxt.typedefs
with
match IdentName.Map.find_opt (Marked.unmark s_name) ctxt.typedefs with
| Some (Name_resolution.TStruct s_uid) -> s_uid
| _ ->
Errors.raise_spanned_error (Marked.get_mark s_name)
@ -366,38 +338,36 @@ let rec translate_expr
(fun s_fields (f_name, f_e) ->
let f_uid =
try
StructMap.find s_uid
(Name_resolution.IdentMap.find (Marked.unmark f_name)
ctxt.field_idmap)
StructName.Map.find s_uid
(IdentName.Map.find (Marked.unmark f_name) ctxt.field_idmap)
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark f_name)
"This identifier should refer to a field of struct %s"
(Marked.unmark s_name)
in
(match StructFieldMap.find_opt f_uid s_fields with
(match StructField.Map.find_opt f_uid s_fields with
| None -> ()
| Some e_field ->
Errors.raise_multispanned_error
[None, Marked.get_mark f_e; None, Expr.pos e_field]
"The field %a has been defined twice:" StructFieldName.format_t
f_uid);
"The field %a has been defined twice:" StructField.format_t f_uid);
let f_e = translate_expr scope inside_definition_of ctxt f_e in
StructFieldMap.add f_uid f_e s_fields)
StructFieldMap.empty fields
StructField.Map.add f_uid f_e s_fields)
StructField.Map.empty fields
in
let expected_s_fields = StructMap.find s_uid ctxt.structs in
StructFieldMap.iter
let expected_s_fields = StructName.Map.find s_uid ctxt.structs in
StructField.Map.iter
(fun expected_f _ ->
if not (StructFieldMap.mem expected_f s_fields) then
if not (StructField.Map.mem expected_f s_fields) then
Errors.raise_spanned_error pos
"Missing field for structure %a: \"%a\"" StructName.format_t s_uid
StructFieldName.format_t expected_f)
StructField.format_t expected_f)
expected_s_fields;
Expr.estruct s_uid s_fields emark
| EnumInject (enum, (constructor, pos_constructor), payload) -> (
let possible_c_uids =
try Name_resolution.IdentMap.find constructor ctxt.constructor_idmap
try IdentName.Map.find constructor ctxt.constructor_idmap
with Not_found ->
Errors.raise_spanned_error pos_constructor
"The name of this constructor has not been defined before, maybe it \
@ -409,7 +379,7 @@ let rec translate_expr
| None ->
if
(* No constructor name was specified *)
EnumMap.cardinal possible_c_uids > 1
EnumName.Map.cardinal possible_c_uids > 1
then
Errors.raise_spanned_error pos_constructor
"This constructor name is ambiguous, it can belong to %a. \
@ -418,9 +388,9 @@ let rec translate_expr
~pp_sep:(fun fmt () -> Format.fprintf fmt " or ")
(fun fmt (s_name, _) ->
Format.fprintf fmt "%a" EnumName.format_t s_name))
(EnumMap.bindings possible_c_uids)
(EnumName.Map.bindings possible_c_uids)
else
let e_uid, c_uid = EnumMap.choose possible_c_uids in
let e_uid, c_uid = EnumName.Map.choose possible_c_uids in
let payload =
Option.map (translate_expr scope inside_definition_of ctxt) payload
in
@ -434,7 +404,7 @@ let rec translate_expr
(* The path has been fully qualified *)
let e_uid = Name_resolution.get_enum ctxt enum in
try
let c_uid = EnumMap.find e_uid possible_c_uids in
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
@ -468,13 +438,13 @@ let rec translate_expr
(Marked.get_mark pattern)
in
let cases =
EnumConstructorMap.mapi
EnumConstructor.Map.mapi
(fun c_uid' tau ->
let nop_var = Var.make "_" in
Expr.make_abs [| nop_var |]
(Expr.elit (LBool (EnumConstructor.compare c_uid c_uid' = 0)) emark)
[tau] pos)
(EnumMap.find enum_uid ctxt.enums)
(EnumName.Map.find enum_uid ctxt.enums)
in
Expr.ematch
(translate_expr scope inside_definition_of ctxt e1)
@ -535,10 +505,6 @@ let rec translate_expr
[TAny, pos]
pos
in
let f_pred_var = Var.make "predicate" in
let f_pred_var_e =
Expr.make_var f_pred_var (Untyped { pos = Marked.get_mark predicate })
in
let acc_var = Var.make "acc" in
let acc_var_e = Expr.make_var acc_var emark in
let item_var = Var.make "item" in
@ -548,8 +514,8 @@ let rec translate_expr
(Expr.eapp
(Expr.eop (Binop cmp_op) (Untyped { pos = pos_op' }))
[
Expr.eapp f_pred_var_e [acc_var_e] emark;
Expr.eapp f_pred_var_e [item_var_e] emark;
Expr.eapp f_pred [acc_var_e] emark;
Expr.eapp f_pred [item_var_e] emark;
]
emark)
acc_var_e item_var_e emark
@ -557,10 +523,7 @@ let rec translate_expr
let fold_f =
Expr.make_abs [| acc_var; item_var |] fold_body [TAny, pos; TAny, pos] pos
in
let fold =
Expr.eapp (Expr.eop (Ternop Fold) emark) [fold_f; init; collection] emark
in
Expr.make_let_in f_pred_var (TAny, pos) f_pred fold pos
Expr.eapp (Expr.eop (Ternop Fold) emark) [fold_f; init; collection] emark
| CollectionOp (op', param', collection, predicate) ->
let ctxt, param =
Name_resolution.add_def_local_var ctxt (Marked.unmark param')
@ -598,12 +561,12 @@ let rec translate_expr
Expr.make_var acc_var (Untyped { pos = Marked.get_mark param' })
in
let f_body =
let make_body (op : binop) =
let make_body (op : desugared binop) =
Expr.eapp (Expr.eop (Binop op) mark)
[acc; translate_expr scope inside_definition_of ctxt predicate]
emark
in
let make_extr_body (cmp_op : binop) (t : typ) =
let make_extr_body (cmp_op : desugared binop) (t : typ) =
let tmp_var = Var.make "tmp" in
let tmp =
Expr.make_var tmp_var (Untyped { pos = Marked.get_mark param' })
@ -743,7 +706,7 @@ and disambiguate_match_and_build_expression
(inside_definition_of : Ast.ScopeDef.t Marked.pos option)
(ctxt : Name_resolution.context)
(cases : Surface.Ast.match_case Marked.pos list) :
Ast.expr boxed EnumConstructorMap.t * EnumName.t =
Ast.expr boxed EnumConstructor.Map.t * EnumName.t =
let create_var = function
| None -> ctxt, Var.make "_"
| Some param ->
@ -758,8 +721,8 @@ and disambiguate_match_and_build_expression
e_binder =
Expr.eabs e_binder
[
EnumConstructorMap.find c_uid
(EnumMap.find e_uid ctxt.Name_resolution.enums);
EnumConstructor.Map.find c_uid
(EnumName.Map.find e_uid ctxt.Name_resolution.enums);
]
(Marked.get_mark case_body)
in
@ -785,7 +748,7 @@ and disambiguate_match_and_build_expression
case were matching constructors of enumeration %a"
EnumName.format_t e_uid EnumName.format_t e_uid'
in
(match EnumConstructorMap.find_opt c_uid cases_d with
(match EnumConstructor.Map.find_opt c_uid cases_d with
| None -> ()
| Some e_case ->
Errors.raise_multispanned_error
@ -799,7 +762,9 @@ and disambiguate_match_and_build_expression
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
EnumConstructorMap.add c_uid case_expr cases_d, Some e_uid, curr_index + 1
( EnumConstructor.Map.add c_uid case_expr cases_d,
Some e_uid,
curr_index + 1 )
| Surface.Ast.WildCard match_case_expr -> (
let nb_cases = List.length cases in
let raise_wildcard_not_last_case_err () =
@ -821,13 +786,13 @@ and disambiguate_match_and_build_expression
| Some e_uid ->
if curr_index < nb_cases - 1 then raise_wildcard_not_last_case_err ();
let missing_constructors =
EnumMap.find e_uid ctxt.Name_resolution.enums
|> EnumConstructorMap.filter_map (fun c_uid _ ->
match EnumConstructorMap.find_opt c_uid cases_d with
EnumName.Map.find e_uid ctxt.Name_resolution.enums
|> EnumConstructor.Map.filter_map (fun c_uid _ ->
match EnumConstructor.Map.find_opt c_uid cases_d with
| Some _ -> None
| None -> Some c_uid)
in
if EnumConstructorMap.is_empty missing_constructors then
if EnumConstructor.Map.is_empty missing_constructors then
Errors.format_spanned_warning case_pos
"Unreachable match case, all constructors of the enumeration %a \
are already specified"
@ -851,19 +816,19 @@ and disambiguate_match_and_build_expression
let e_binder = Expr.bind [| payload_var |] case_body in
(* For each missing cases, binds the wildcard payload. *)
EnumConstructorMap.fold
EnumConstructor.Map.fold
(fun c_uid _ (cases_d, e_uid_opt, curr_index) ->
let case_expr =
bind_case_body c_uid e_uid ctxt case_body e_binder
in
( EnumConstructorMap.add c_uid case_expr cases_d,
( EnumConstructor.Map.add c_uid case_expr cases_d,
e_uid_opt,
curr_index + 1 ))
missing_constructors
(cases_d, Some e_uid, curr_index))
in
let naked_expr, e_name, _ =
List.fold_left bind_match_cases (EnumConstructorMap.empty, None, 0) cases
List.fold_left bind_match_cases (EnumConstructor.Map.empty, None, 0) cases
in
naked_expr, Option.get e_name
[@@ocamlformat "wrap-comments=false"]
@ -934,8 +899,8 @@ let process_def
(ctxt : Name_resolution.context)
(prgm : Ast.program)
(def : Surface.Ast.definition) : Ast.program =
let scope : Ast.scope = ScopeMap.find scope_uid prgm.program_scopes in
let scope_ctxt = ScopeMap.find scope_uid ctxt.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 def_key =
Name_resolution.get_def_key
(Marked.unmark def.definition_name)
@ -962,8 +927,7 @@ let process_def
match def.definition_label with
| Some (label_str, label_pos) ->
Ast.ExplicitlyLabeled
( Name_resolution.IdentMap.find label_str scope_def_ctxt.label_idmap,
label_pos )
(IdentName.Map.find label_str scope_def_ctxt.label_idmap, label_pos)
| None -> Ast.Unlabeled
in
let exception_situation =
@ -980,7 +944,7 @@ let process_def
| ExceptionToLabel label_str -> (
try
let label_id =
Name_resolution.IdentMap.find (Marked.unmark label_str)
IdentName.Map.find (Marked.unmark label_str)
scope_def_ctxt.label_idmap
in
ExceptionToLabel (label_id, Marked.get_mark label_str)
@ -994,7 +958,7 @@ let process_def
{
scope_def with
scope_def_rules =
RuleMap.add rule_name
RuleName.Map.add rule_name
(process_default new_ctxt scope_uid
(def_key, Marked.get_mark def.definition_name)
rule_name param_uid precond exception_situation label_situation
@ -1009,7 +973,8 @@ let process_def
in
{
prgm with
program_scopes = ScopeMap.add scope_uid scope_updated prgm.program_scopes;
program_scopes =
ScopeName.Map.add scope_uid scope_updated prgm.program_scopes;
}
(** Translates a {!type: Surface.Ast.rule} from the surface language *)
@ -1029,7 +994,7 @@ let process_assert
(ctxt : Name_resolution.context)
(prgm : Ast.program)
(ass : Surface.Ast.assertion) : Ast.program =
let scope : Ast.scope = ScopeMap.find scope_uid prgm.program_scopes in
let scope : Ast.scope = ScopeName.Map.find scope_uid prgm.program_scopes in
let ass =
translate_expr scope_uid None ctxt
(match ass.Surface.Ast.assertion_condition with
@ -1055,7 +1020,7 @@ let process_assert
in
{
prgm with
program_scopes = ScopeMap.add scope_uid new_scope prgm.program_scopes;
program_scopes = ScopeName.Map.add scope_uid new_scope prgm.program_scopes;
}
(** Translates a surface definition, rule or assertion *)
@ -1080,7 +1045,7 @@ let check_unlabeled_exception
(scope : ScopeName.t)
(ctxt : Name_resolution.context)
(item : Surface.Ast.scope_use_item Marked.pos) : unit =
let scope_ctxt = ScopeMap.find scope ctxt.scopes in
let scope_ctxt = ScopeName.Map.find scope ctxt.scopes in
match Marked.unmark item with
| Surface.Ast.Rule _ | Surface.Ast.Definition _ -> (
let def_key, exception_to =
@ -1129,7 +1094,7 @@ let process_scope_use
let scope_uid = Name_resolution.get_scope ctxt use.scope_use_name in
(* Make sure the scope exists *)
let prgm =
match ScopeMap.find_opt scope_uid prgm.program_scopes with
match ScopeName.Map.find_opt scope_uid prgm.program_scopes with
| Some _ -> prgm
| None -> assert false
(* should not happen *)
@ -1155,21 +1120,20 @@ let attribute_to_io (attr : Surface.Ast.scope_decl_context_io) : Ast.io =
let init_scope_defs
(ctxt : Name_resolution.context)
(scope_idmap :
Name_resolution.scope_var_or_subscope Name_resolution.IdentMap.t) :
(scope_idmap : Name_resolution.scope_var_or_subscope IdentName.Map.t) :
Ast.scope_def Ast.ScopeDefMap.t =
(* Initializing the definitions of all scopes and subscope vars, with no rules
yet inside *)
let add_def _ v scope_def_map =
match v with
| Name_resolution.ScopeVar v -> (
let v_sig = ScopeVarMap.find v ctxt.Name_resolution.var_typs in
let v_sig = ScopeVar.Map.find v ctxt.Name_resolution.var_typs in
match v_sig.var_sig_states_list with
| [] ->
let def_key = Ast.ScopeDef.Var (v, None) in
Ast.ScopeDefMap.add def_key
{
Ast.scope_def_rules = RuleMap.empty;
Ast.scope_def_rules = RuleName.Map.empty;
Ast.scope_def_typ = v_sig.var_sig_typ;
Ast.scope_def_is_condition = v_sig.var_sig_is_condition;
Ast.scope_def_io = attribute_to_io v_sig.var_sig_io;
@ -1182,7 +1146,7 @@ let init_scope_defs
let def_key = Ast.ScopeDef.Var (v, Some state) in
let def =
{
Ast.scope_def_rules = RuleMap.empty;
Ast.scope_def_rules = RuleName.Map.empty;
Ast.scope_def_typ = v_sig.var_sig_typ;
Ast.scope_def_is_condition = v_sig.var_sig_is_condition;
Ast.scope_def_io =
@ -1209,23 +1173,23 @@ let init_scope_defs
scope_def)
| Name_resolution.SubScope (v0, subscope_uid) ->
let sub_scope_def =
ScopeMap.find subscope_uid ctxt.Name_resolution.scopes
ScopeName.Map.find subscope_uid ctxt.Name_resolution.scopes
in
Name_resolution.IdentMap.fold
IdentName.Map.fold
(fun _ v scope_def_map ->
match v with
| Name_resolution.SubScope _ -> scope_def_map
| Name_resolution.ScopeVar v ->
(* TODO: shouldn't we ignore internal variables too at this point
? *)
let v_sig = ScopeVarMap.find v ctxt.Name_resolution.var_typs in
let v_sig = ScopeVar.Map.find v ctxt.Name_resolution.var_typs in
let def_key =
Ast.ScopeDef.SubScopeVar
(v0, v, Marked.get_mark (ScopeVar.get_info v))
in
Ast.ScopeDefMap.add def_key
{
Ast.scope_def_rules = RuleMap.empty;
Ast.scope_def_rules = RuleName.Map.empty;
Ast.scope_def_typ = v_sig.var_sig_typ;
Ast.scope_def_is_condition = v_sig.var_sig_is_condition;
Ast.scope_def_io = attribute_to_io v_sig.var_sig_io;
@ -1233,7 +1197,7 @@ let init_scope_defs
scope_def_map)
sub_scope_def.Name_resolution.var_idmap scope_def_map
in
Name_resolution.IdentMap.fold add_def scope_idmap Ast.ScopeDefMap.empty
IdentName.Map.fold add_def scope_idmap Ast.ScopeDefMap.empty
(** Main function of this module *)
let translate_program
@ -1241,28 +1205,28 @@ let translate_program
(prgm : Surface.Ast.program) : Ast.program =
let empty_prgm =
let program_scopes =
ScopeMap.mapi
ScopeName.Map.mapi
(fun s_uid s_context ->
let scope_vars =
Name_resolution.IdentMap.fold
IdentName.Map.fold
(fun _ v acc ->
match v with
| Name_resolution.SubScope _ -> acc
| Name_resolution.ScopeVar v -> (
let v_sig = ScopeVarMap.find v ctxt.var_typs in
let v_sig = ScopeVar.Map.find v ctxt.var_typs in
match v_sig.var_sig_states_list with
| [] -> ScopeVarMap.add v Ast.WholeVar acc
| states -> ScopeVarMap.add v (Ast.States states) acc))
s_context.Name_resolution.var_idmap ScopeVarMap.empty
| [] -> ScopeVar.Map.add v Ast.WholeVar acc
| states -> ScopeVar.Map.add v (Ast.States states) acc))
s_context.Name_resolution.var_idmap ScopeVar.Map.empty
in
let scope_sub_scopes =
Name_resolution.IdentMap.fold
IdentName.Map.fold
(fun _ v acc ->
match v with
| Name_resolution.ScopeVar _ -> acc
| Name_resolution.SubScope (sub_var, sub_scope) ->
SubScopeMap.add sub_var sub_scope acc)
s_context.Name_resolution.var_idmap SubScopeMap.empty
SubScopeName.Map.add sub_var sub_scope acc)
s_context.Name_resolution.var_idmap SubScopeName.Map.empty
in
{
Ast.scope_vars;
@ -1280,13 +1244,14 @@ let translate_program
ctx_structs = ctxt.Name_resolution.structs;
ctx_enums = ctxt.Name_resolution.enums;
ctx_scopes =
Name_resolution.IdentMap.fold
IdentName.Map.fold
(fun _ def acc ->
match def with
| Name_resolution.TScope (scope, scope_out_struct) ->
ScopeMap.add scope scope_out_struct acc
ScopeName.Map.add scope scope_out_struct acc
| _ -> acc)
ctxt.Name_resolution.typedefs ScopeMap.empty;
ctxt.Name_resolution.typedefs ScopeName.Map.empty;
ctx_struct_fields = ctxt.Name_resolution.field_idmap;
};
Ast.program_scopes;
}

363
compiler/desugared/name_resolution.ml
View File

@ -18,22 +18,18 @@
(** Builds a context that allows for mapping each name to a precise uid, taking
lexical scopes into account *)
open Utils
open Catala_utils
open Shared_ast
(** {1 Name resolution context} *)
type ident = string
module IdentMap : Map.S with type key = String.t = Map.Make (String)
type unique_rulename =
| Ambiguous of Pos.t list
| Unique of RuleName.t Marked.pos
type scope_def_context = {
default_exception_rulename : unique_rulename option;
label_idmap : LabelName.t IdentMap.t;
label_idmap : LabelName.t IdentName.Map.t;
}
type scope_var_or_subscope =
@ -41,26 +37,26 @@ type scope_var_or_subscope =
| SubScope of SubScopeName.t * ScopeName.t
type scope_context = {
var_idmap : scope_var_or_subscope IdentMap.t;
var_idmap : scope_var_or_subscope IdentName.Map.t;
(** All variables, including scope variables and subscopes *)
scope_defs_contexts : scope_def_context Ast.ScopeDefMap.t;
(** What is the default rule to refer to for unnamed exceptions, if any *)
sub_scopes : ScopeSet.t;
sub_scopes : ScopeName.Set.t;
(** Other scopes referred to by this scope. Used for dependency analysis *)
}
(** Inside a scope, we distinguish between the variables and the subscopes. *)
type struct_context = typ StructFieldMap.t
type struct_context = typ StructField.Map.t
(** Types of the fields of a struct *)
type enum_context = typ EnumConstructorMap.t
type enum_context = typ EnumConstructor.Map.t
(** Types of the payloads of the cases of an enum *)
type var_sig = {
var_sig_typ : typ;
var_sig_is_condition : bool;
var_sig_io : Surface.Ast.scope_decl_context_io;
var_sig_states_idmap : StateName.t IdentMap.t;
var_sig_states_idmap : StateName.t IdentName.Map.t;
var_sig_states_list : StateName.t list;
}
@ -73,21 +69,22 @@ type typedef =
(** Implicitly defined output struct *)
type context = {
local_var_idmap : Ast.expr Var.t IdentMap.t;
local_var_idmap : Ast.expr Var.t IdentName.Map.t;
(** Inside a definition, local variables can be introduced by functions
arguments or pattern matching *)
typedefs : typedef IdentMap.t;
typedefs : typedef IdentName.Map.t;
(** Gathers the names of the scopes, structs and enums *)
field_idmap : StructFieldName.t StructMap.t IdentMap.t;
field_idmap : StructField.t StructName.Map.t IdentName.Map.t;
(** The names of the struct fields. Names of fields can be shared between
different structs *)
constructor_idmap : EnumConstructor.t EnumMap.t IdentMap.t;
constructor_idmap : EnumConstructor.t EnumName.Map.t IdentName.Map.t;
(** The names of the enum constructors. Constructor names can be shared
between different enums *)
scopes : scope_context ScopeMap.t; (** For each scope, its context *)
structs : struct_context StructMap.t; (** For each struct, its context *)
enums : enum_context EnumMap.t; (** For each enum, its context *)
var_typs : var_sig ScopeVarMap.t;
scopes : scope_context ScopeName.Map.t; (** For each scope, its context *)
structs : struct_context StructName.Map.t;
(** For each struct, its context *)
enums : enum_context EnumName.Map.t; (** For each enum, its context *)
var_typs : var_sig ScopeVar.Map.t;
(** The signatures of each scope variable declared *)
}
(** Main context used throughout {!module: Surface.Desugaring} *)
@ -101,30 +98,30 @@ let raise_unsupported_feature (msg : string) (pos : Pos.t) =
(** Function to call whenever an identifier used somewhere has not been declared
in the program previously *)
let raise_unknown_identifier (msg : string) (ident : ident Marked.pos) =
let raise_unknown_identifier (msg : string) (ident : IdentName.t Marked.pos) =
Errors.raise_spanned_error (Marked.get_mark ident)
"\"%s\": unknown identifier %s"
(Utils.Cli.with_style [ANSITerminal.yellow] "%s" (Marked.unmark ident))
(Cli.with_style [ANSITerminal.yellow] "%s" (Marked.unmark ident))
msg
(** Gets the type associated to an uid *)
let get_var_typ (ctxt : context) (uid : ScopeVar.t) : typ =
(ScopeVarMap.find uid ctxt.var_typs).var_sig_typ
(ScopeVar.Map.find uid ctxt.var_typs).var_sig_typ
let is_var_cond (ctxt : context) (uid : ScopeVar.t) : bool =
(ScopeVarMap.find uid ctxt.var_typs).var_sig_is_condition
(ScopeVar.Map.find uid ctxt.var_typs).var_sig_is_condition
let get_var_io (ctxt : context) (uid : ScopeVar.t) :
Surface.Ast.scope_decl_context_io =
(ScopeVarMap.find uid ctxt.var_typs).var_sig_io
(ScopeVar.Map.find uid ctxt.var_typs).var_sig_io
(** Get the variable uid inside the scope given in argument *)
let get_var_uid
(scope_uid : ScopeName.t)
(ctxt : context)
((x, pos) : ident Marked.pos) : ScopeVar.t =
let scope = ScopeMap.find scope_uid ctxt.scopes in
match IdentMap.find_opt x scope.var_idmap with
((x, pos) : IdentName.t Marked.pos) : ScopeVar.t =
let scope = ScopeName.Map.find scope_uid ctxt.scopes in
match IdentName.Map.find_opt x scope.var_idmap with
| Some (ScopeVar uid) -> uid
| _ ->
raise_unknown_identifier
@ -135,26 +132,26 @@ let get_var_uid
let get_subscope_uid
(scope_uid : ScopeName.t)
(ctxt : context)
((y, pos) : ident Marked.pos) : SubScopeName.t =
let scope = ScopeMap.find scope_uid ctxt.scopes in
match IdentMap.find_opt y scope.var_idmap with
((y, pos) : IdentName.t Marked.pos) : SubScopeName.t =
let scope = ScopeName.Map.find scope_uid ctxt.scopes in
match IdentName.Map.find_opt y scope.var_idmap with
| Some (SubScope (sub_uid, _sub_id)) -> sub_uid
| _ -> raise_unknown_identifier "for a subscope of this scope" (y, pos)
(** [is_subscope_uid scope_uid ctxt y] returns true if [y] belongs to the
subscopes of [scope_uid]. *)
let is_subscope_uid (scope_uid : ScopeName.t) (ctxt : context) (y : ident) :
bool =
let scope = ScopeMap.find scope_uid ctxt.scopes in
match IdentMap.find_opt y scope.var_idmap with
let is_subscope_uid (scope_uid : ScopeName.t) (ctxt : context) (y : IdentName.t)
: bool =
let scope = ScopeName.Map.find scope_uid ctxt.scopes in
match IdentName.Map.find_opt y scope.var_idmap with
| Some (SubScope _) -> true
| _ -> false
(** Checks if the var_uid belongs to the scope scope_uid *)
let belongs_to (ctxt : context) (uid : ScopeVar.t) (scope_uid : ScopeName.t) :
bool =
let scope = ScopeMap.find scope_uid ctxt.scopes in
IdentMap.exists
let scope = ScopeName.Map.find scope_uid ctxt.scopes in
IdentName.Map.exists
(fun _ -> function
| ScopeVar var_uid -> ScopeVar.equal uid var_uid
| _ -> false)
@ -178,7 +175,7 @@ let is_def_cond (ctxt : context) (def : Ast.ScopeDef.t) : bool =
is_var_cond ctxt x
let get_enum ctxt id =
match IdentMap.find (Marked.unmark id) ctxt.typedefs with
match IdentName.Map.find (Marked.unmark id) ctxt.typedefs with
| TEnum id -> id
| TStruct sid ->
Errors.raise_multispanned_error
@ -199,7 +196,7 @@ let get_enum ctxt id =
(Marked.unmark id)
let get_struct ctxt id =
match IdentMap.find (Marked.unmark id) ctxt.typedefs with
match IdentName.Map.find (Marked.unmark id) ctxt.typedefs with
| TStruct id | TScope (_, { out_struct_name = id; _ }) -> id
| TEnum eid ->
Errors.raise_multispanned_error
@ -213,7 +210,7 @@ let get_struct ctxt id =
(Marked.unmark id)
let get_scope ctxt id =
match IdentMap.find (Marked.unmark id) ctxt.typedefs with
match IdentName.Map.find (Marked.unmark id) ctxt.typedefs with
| TScope (id, _) -> id
| TEnum eid ->
Errors.raise_multispanned_error
@ -242,8 +239,8 @@ let process_subscope_decl
(decl : Surface.Ast.scope_decl_context_scope) : context =
let name, name_pos = decl.scope_decl_context_scope_name in
let subscope, s_pos = decl.scope_decl_context_scope_sub_scope in
let scope_ctxt = ScopeMap.find scope ctxt.scopes in
match IdentMap.find_opt subscope scope_ctxt.var_idmap with
let scope_ctxt = ScopeName.Map.find scope ctxt.scopes in
match IdentName.Map.find_opt subscope scope_ctxt.var_idmap with
| Some use ->
let info =
match use with
@ -253,7 +250,7 @@ let process_subscope_decl
Errors.raise_multispanned_error
[Some "first use", Marked.get_mark info; Some "second use", s_pos]
"Subscope name \"%a\" already used"
(Utils.Cli.format_with_style [ANSITerminal.yellow])
(Cli.format_with_style [ANSITerminal.yellow])
subscope
| None ->
let sub_scope_uid = SubScopeName.fresh (name, name_pos) in
@ -264,13 +261,14 @@ let process_subscope_decl
{
scope_ctxt with
var_idmap =
IdentMap.add name
IdentName.Map.add name
(SubScope (sub_scope_uid, original_subscope_uid))
scope_ctxt.var_idmap;
sub_scopes = ScopeSet.add original_subscope_uid scope_ctxt.sub_scopes;
sub_scopes =
ScopeName.Set.add original_subscope_uid scope_ctxt.sub_scopes;
}
in
{ ctxt with scopes = ScopeMap.add scope scope_ctxt ctxt.scopes }
{ ctxt with scopes = ScopeName.Map.add scope scope_ctxt ctxt.scopes }
let is_type_cond ((typ, _) : Surface.Ast.typ) =
match typ with
@ -300,7 +298,7 @@ let rec process_base_typ
| Surface.Ast.Boolean -> TLit TBool, typ_pos
| Surface.Ast.Text -> raise_unsupported_feature "text type" typ_pos
| Surface.Ast.Named ident -> (
match IdentMap.find_opt ident ctxt.typedefs with
match IdentName.Map.find_opt ident ctxt.typedefs with
| Some (TStruct s_uid) -> TStruct s_uid, typ_pos
| Some (TEnum e_uid) -> TEnum e_uid, typ_pos
| Some (TScope (_, scope_str)) ->
@ -308,7 +306,7 @@ let rec process_base_typ
| None ->
Errors.raise_spanned_error typ_pos
"Unknown type \"%a\", not a struct or enum previously declared"
(Utils.Cli.format_with_style [ANSITerminal.yellow])
(Cli.format_with_style [ANSITerminal.yellow])
ident))
(** Process a type (function or not) *)
@ -329,8 +327,8 @@ let process_data_decl
let data_typ = process_type ctxt decl.scope_decl_context_item_typ in
let is_cond = is_type_cond decl.scope_decl_context_item_typ in
let name, pos = decl.scope_decl_context_item_name in
let scope_ctxt = ScopeMap.find scope ctxt.scopes in
match IdentMap.find_opt name scope_ctxt.var_idmap with
let scope_ctxt = ScopeName.Map.find scope ctxt.scopes in
match IdentName.Map.find_opt name scope_ctxt.var_idmap with
| Some use ->
let info =
match use with
@ -340,29 +338,29 @@ let process_data_decl
Errors.raise_multispanned_error
[Some "First use:", Marked.get_mark info; Some "Second use:", pos]
"Variable name \"%a\" already used"
(Utils.Cli.format_with_style [ANSITerminal.yellow])
(Cli.format_with_style [ANSITerminal.yellow])
name
| None ->
let uid = ScopeVar.fresh (name, pos) in
let scope_ctxt =
{
scope_ctxt with
var_idmap = IdentMap.add name (ScopeVar uid) scope_ctxt.var_idmap;
var_idmap = IdentName.Map.add name (ScopeVar uid) scope_ctxt.var_idmap;
}
in
let states_idmap, states_list =
List.fold_right
(fun state_id (states_idmap, states_list) ->
let state_uid = StateName.fresh state_id in
( IdentMap.add (Marked.unmark state_id) state_uid states_idmap,
( IdentName.Map.add (Marked.unmark state_id) state_uid states_idmap,
state_uid :: states_list ))
decl.scope_decl_context_item_states (IdentMap.empty, [])
decl.scope_decl_context_item_states (IdentName.Map.empty, [])
in
{
ctxt with
scopes = ScopeMap.add scope scope_ctxt ctxt.scopes;
scopes = ScopeName.Map.add scope scope_ctxt ctxt.scopes;
var_typs =
ScopeVarMap.add uid
ScopeVar.Map.add uid
{
var_sig_typ = data_typ;
var_sig_is_condition = is_cond;
@ -374,13 +372,14 @@ let process_data_decl
}
(** Adds a binding to the context *)
let add_def_local_var (ctxt : context) (name : ident) : context * Ast.expr Var.t
=
let add_def_local_var (ctxt : context) (name : IdentName.t) :
context * Ast.expr Var.t =
let local_var_uid = Var.make name in
let ctxt =
{
ctxt with
local_var_idmap = IdentMap.add name local_var_uid ctxt.local_var_idmap;
local_var_idmap =
IdentName.Map.add name local_var_uid ctxt.local_var_idmap;
}
in
ctxt, local_var_uid
@ -397,35 +396,33 @@ let process_struct_decl (ctxt : context) (sdecl : Surface.Ast.struct_decl) :
(Marked.unmark sdecl.struct_decl_name);
List.fold_left
(fun ctxt (fdecl, _) ->
let f_uid =
StructFieldName.fresh fdecl.Surface.Ast.struct_decl_field_name
in
let f_uid = StructField.fresh fdecl.Surface.Ast.struct_decl_field_name in
let ctxt =
{
ctxt with
field_idmap =
IdentMap.update
IdentName.Map.update
(Marked.unmark fdecl.Surface.Ast.struct_decl_field_name)
(fun uids ->
match uids with
| None -> Some (StructMap.singleton s_uid f_uid)
| Some uids -> Some (StructMap.add s_uid f_uid uids))
| None -> Some (StructName.Map.singleton s_uid f_uid)
| Some uids -> Some (StructName.Map.add s_uid f_uid uids))
ctxt.field_idmap;
}
in
{
ctxt with
structs =
StructMap.update s_uid
StructName.Map.update s_uid
(fun fields ->
match fields with
| None ->
Some
(StructFieldMap.singleton f_uid
(StructField.Map.singleton f_uid
(process_type ctxt fdecl.Surface.Ast.struct_decl_field_typ))
| Some fields ->
Some
(StructFieldMap.add f_uid
(StructField.Map.add f_uid
(process_type ctxt fdecl.Surface.Ast.struct_decl_field_typ)
fields))
ctxt.structs;
@ -449,19 +446,19 @@ let process_enum_decl (ctxt : context) (edecl : Surface.Ast.enum_decl) : context
{
ctxt with
constructor_idmap =
IdentMap.update
IdentName.Map.update
(Marked.unmark cdecl.Surface.Ast.enum_decl_case_name)
(fun uids ->
match uids with
| None -> Some (EnumMap.singleton e_uid c_uid)
| Some uids -> Some (EnumMap.add e_uid c_uid uids))
| None -> Some (EnumName.Map.singleton e_uid c_uid)
| Some uids -> Some (EnumName.Map.add e_uid c_uid uids))
ctxt.constructor_idmap;
}
in
{
ctxt with
enums =
EnumMap.update e_uid
EnumName.Map.update e_uid
(fun cases ->
let typ =
match cdecl.Surface.Ast.enum_decl_case_typ with
@ -469,8 +466,8 @@ let process_enum_decl (ctxt : context) (edecl : Surface.Ast.enum_decl) : context
| Some typ -> process_type ctxt typ
in
match cases with
| None -> Some (EnumConstructorMap.singleton c_uid typ)
| Some fields -> Some (EnumConstructorMap.add c_uid typ fields))
| None -> Some (EnumConstructor.Map.singleton c_uid typ)
| Some fields -> Some (EnumConstructor.Map.add c_uid typ fields))
ctxt.enums;
})
ctxt edecl.enum_decl_cases
@ -522,9 +519,9 @@ let process_scope_decl (ctxt : context) (decl : Surface.Ast.scope_decl) :
{
ctxt with
structs =
StructMap.add
StructName.Map.add
(get_struct ctxt decl.scope_decl_name)
StructFieldMap.empty ctxt.structs;
StructField.Map.empty ctxt.structs;
}
else
let ctxt =
@ -535,23 +532,23 @@ let process_scope_decl (ctxt : context) (decl : Surface.Ast.scope_decl) :
}
in
let out_struct_fields =
let sco = ScopeMap.find scope_uid ctxt.scopes in
let sco = ScopeName.Map.find scope_uid ctxt.scopes in
let str = get_struct ctxt decl.scope_decl_name in
IdentMap.fold
IdentName.Map.fold
(fun id var svmap ->
match var with
| SubScope _ -> svmap
| ScopeVar v -> (
try
let field =
StructMap.find str (IdentMap.find id ctxt.field_idmap)
StructName.Map.find str (IdentName.Map.find id ctxt.field_idmap)
in
ScopeVarMap.add v field svmap
ScopeVar.Map.add v field svmap
with Not_found -> svmap))
sco.var_idmap ScopeVarMap.empty
sco.var_idmap ScopeVar.Map.empty
in
let typedefs =
IdentMap.update
IdentName.Map.update
(Marked.unmark decl.scope_decl_name)
(function
| Some (TScope (scope, { out_struct_name; _ })) ->
@ -576,7 +573,7 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
Some "Second definition:", pos;
]
"%s name \"%a\" already defined" msg
(Utils.Cli.format_with_style [ANSITerminal.yellow])
(Cli.format_with_style [ANSITerminal.yellow])
name
in
match Marked.unmark item with
@ -586,26 +583,26 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
Option.iter
(fun use ->
raise_already_defined_error (typedef_info use) name pos "scope")
(IdentMap.find_opt name ctxt.typedefs);
(IdentName.Map.find_opt name ctxt.typedefs);
let scope_uid = ScopeName.fresh (name, pos) in
let out_struct_uid = StructName.fresh (name, pos) in
{
ctxt with
typedefs =
IdentMap.add name
IdentName.Map.add name
(TScope
( scope_uid,
{
out_struct_name = out_struct_uid;
out_struct_fields = ScopeVarMap.empty;
out_struct_fields = ScopeVar.Map.empty;
} ))
ctxt.typedefs;
scopes =
ScopeMap.add scope_uid
ScopeName.Map.add scope_uid
{
var_idmap = IdentMap.empty;
var_idmap = IdentName.Map.empty;
scope_defs_contexts = Ast.ScopeDefMap.empty;
sub_scopes = ScopeSet.empty;
sub_scopes = ScopeName.Set.empty;
}
ctxt.scopes;
}
@ -614,12 +611,12 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
Option.iter
(fun use ->
raise_already_defined_error (typedef_info use) name pos "struct")
(IdentMap.find_opt name ctxt.typedefs);
(IdentName.Map.find_opt name ctxt.typedefs);
let s_uid = StructName.fresh sdecl.struct_decl_name in
{
ctxt with
typedefs =
IdentMap.add
IdentName.Map.add
(Marked.unmark sdecl.struct_decl_name)
(TStruct s_uid) ctxt.typedefs;
}
@ -628,12 +625,12 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
Option.iter
(fun use ->
raise_already_defined_error (typedef_info use) name pos "enum")
(IdentMap.find_opt name ctxt.typedefs);
(IdentName.Map.find_opt name ctxt.typedefs);
let e_uid = EnumName.fresh edecl.enum_decl_name in
{
ctxt with
typedefs =
IdentMap.add
IdentName.Map.add
(Marked.unmark edecl.enum_decl_name)
(TEnum e_uid) ctxt.typedefs;
}
@ -679,18 +676,19 @@ let get_def_key
(scope_uid : ScopeName.t)
(ctxt : context)
(pos : Pos.t) : Ast.ScopeDef.t =
let scope_ctxt = ScopeMap.find scope_uid ctxt.scopes in
let scope_ctxt = ScopeName.Map.find scope_uid ctxt.scopes in
match name with
| [x] ->
let x_uid = get_var_uid scope_uid ctxt x in
let var_sig = ScopeVarMap.find x_uid ctxt.var_typs in
let var_sig = ScopeVar.Map.find x_uid ctxt.var_typs in
Ast.ScopeDef.Var
( x_uid,
match state with
| Some state -> (
try
Some
(IdentMap.find (Marked.unmark state) var_sig.var_sig_states_idmap)
(IdentName.Map.find (Marked.unmark state)
var_sig.var_sig_states_idmap)
with Not_found ->
Errors.raise_multispanned_error
[
@ -701,7 +699,7 @@ let get_def_key
"This identifier is not a state declared for variable %a."
ScopeVar.format_t x_uid)
| None ->
if not (IdentMap.is_empty var_sig.var_sig_states_idmap) then
if not (IdentName.Map.is_empty var_sig.var_sig_states_idmap) then
Errors.raise_multispanned_error
[
None, Marked.get_mark x;
@ -714,7 +712,7 @@ let get_def_key
else None )
| [y; x] ->
let (subscope_uid, subscope_real_uid) : SubScopeName.t * ScopeName.t =
match IdentMap.find_opt (Marked.unmark y) scope_ctxt.var_idmap with
match IdentName.Map.find_opt (Marked.unmark y) scope_ctxt.var_idmap with
| Some (SubScope (v, u)) -> v, u
| Some _ ->
Errors.raise_spanned_error pos
@ -732,6 +730,73 @@ let get_def_key
subscope variable. In particular, it is not possible to define struct \
fields individually in Catala."
let update_def_key_ctx
(d : Surface.Ast.definition)
(def_key_ctx : scope_def_context) : scope_def_context =
(* First, we update the def key context with information about the
definition's label*)
let def_key_ctx =
match d.Surface.Ast.definition_label with
| None -> def_key_ctx
| Some label ->
let new_label_idmap =
IdentName.Map.update (Marked.unmark label)
(fun existing_label ->
match existing_label with
| Some existing_label -> Some existing_label
| None -> Some (LabelName.fresh label))
def_key_ctx.label_idmap
in
{ def_key_ctx with label_idmap = new_label_idmap }
in
(* And second, we update the map of default rulenames for unlabeled
exceptions *)
match d.Surface.Ast.definition_exception_to with
(* If this definition is an exception, it cannot be a default definition *)
| UnlabeledException | ExceptionToLabel _ -> def_key_ctx
(* If it is not an exception, we need to distinguish between several cases *)
| NotAnException -> (
match def_key_ctx.default_exception_rulename with
(* There was already a default definition for this key. If we need it, it is
ambiguous *)
| Some old ->
{
def_key_ctx with
default_exception_rulename =
Some
(Ambiguous
([Marked.get_mark d.definition_name]
@
match old with Ambiguous old -> old | Unique (_, pos) -> [pos]));
}
(* No definition has been set yet for this key *)
| None -> (
match d.Surface.Ast.definition_label with
(* This default definition has a label. This is not allowed for unlabeled
exceptions *)
| Some _ ->
{
def_key_ctx with
default_exception_rulename =
Some (Ambiguous [Marked.get_mark d.definition_name]);
}
(* This is a possible default definition for this key. We create and store
a fresh rulename *)
| None ->
{
def_key_ctx with
default_exception_rulename =
Some (Unique (d.definition_id, Marked.get_mark d.definition_name));
}))
let empty_def_key_ctx =
{
(* Here, this is the first time we encounter a definition for this
definition key *)
default_exception_rulename = None;
label_idmap = IdentName.Map.empty;
}
let process_definition
(ctxt : context)
(s_name : ScopeName.t)
@ -740,7 +805,7 @@ let process_definition
{
ctxt with
scopes =
ScopeMap.update s_name
ScopeName.Map.update s_name
(fun (s_ctxt : scope_context option) ->
let def_key =
get_def_key
@ -757,85 +822,9 @@ let process_definition
scope_defs_contexts =
Ast.ScopeDefMap.update def_key
(fun def_key_ctx ->
let def_key_ctx : scope_def_context =
Option.fold
~none:
{
(* Here, this is the first time we encounter a
definition for this definition key *)
default_exception_rulename = None;
label_idmap = IdentMap.empty;
}
~some:(fun x -> x)
def_key_ctx
in
(* First, we update the def key context with information
about the definition's label*)
let def_key_ctx =
match d.Surface.Ast.definition_label with
| None -> def_key_ctx
| Some label ->
let new_label_idmap =
IdentMap.update (Marked.unmark label)
(fun existing_label ->
match existing_label with
| Some existing_label -> Some existing_label
| None -> Some (LabelName.fresh label))
def_key_ctx.label_idmap
in
{ def_key_ctx with label_idmap = new_label_idmap }
in
(* And second, we update the map of default rulenames for
unlabeled exceptions *)
let def_key_ctx =
match d.Surface.Ast.definition_exception_to with
(* If this definition is an exception, it cannot be a
default definition *)
| UnlabeledException | ExceptionToLabel _ -> def_key_ctx
(* If it is not an exception, we need to distinguish
between several cases *)
| NotAnException -> (
match def_key_ctx.default_exception_rulename with
(* There was already a default definition for this
key. If we need it, it is ambiguous *)
| Some old ->
{
def_key_ctx with
default_exception_rulename =
Some
(Ambiguous
([Marked.get_mark d.definition_name]
@
match old with
| Ambiguous old -> old
| Unique (_, pos) -> [pos]));
}
(* No definition has been set yet for this key *)
| None -> (
match d.Surface.Ast.definition_label with
(* This default definition has a label. This is not
allowed for unlabeled exceptions *)
| Some _ ->
{
def_key_ctx with
default_exception_rulename =
Some
(Ambiguous
[Marked.get_mark d.definition_name]);
}
(* This is a possible default definition for this
key. We create and store a fresh rulename *)
| None ->
{
def_key_ctx with
default_exception_rulename =
Some
(Unique
( d.definition_id,
Marked.get_mark d.definition_name ));
}))
in
Some def_key_ctx)
Some
(update_def_key_ctx d
(Option.value ~default:empty_def_key_ctx def_key_ctx)))
s_ctxt.scope_defs_contexts;
})
ctxt.scopes;
@ -854,7 +843,7 @@ let process_scope_use (ctxt : context) (suse : Surface.Ast.scope_use) : context
=
let s_name =
match
IdentMap.find_opt
IdentName.Map.find_opt
(Marked.unmark suse.Surface.Ast.scope_use_name)
ctxt.typedefs
with
@ -863,7 +852,7 @@ let process_scope_use (ctxt : context) (suse : Surface.Ast.scope_use) : context
Errors.raise_spanned_error
(Marked.get_mark suse.Surface.Ast.scope_use_name)
"\"%a\": this scope has not been declared anywhere, is it a typo?"
(Utils.Cli.format_with_style [ANSITerminal.yellow])
(Cli.format_with_style [ANSITerminal.yellow])
(Marked.unmark suse.Surface.Ast.scope_use_name)
in
List.fold_left
@ -882,14 +871,14 @@ let process_use_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
let form_context (prgm : Surface.Ast.program) : context =
let empty_ctxt =
{
local_var_idmap = IdentMap.empty;
typedefs = IdentMap.empty;
scopes = ScopeMap.empty;
var_typs = ScopeVarMap.empty;
structs = StructMap.empty;
field_idmap = IdentMap.empty;
enums = EnumMap.empty;
constructor_idmap = IdentMap.empty;
local_var_idmap = IdentName.Map.empty;
typedefs = IdentName.Map.empty;
scopes = ScopeName.Map.empty;
var_typs = ScopeVar.Map.empty;
structs = StructName.Map.empty;
field_idmap = IdentName.Map.empty;
enums = EnumName.Map.empty;
constructor_idmap = IdentName.Map.empty;
}
in
let ctxt =

51
compiler/desugared/name_resolution.mli
View File

@ -18,22 +18,18 @@
(** Builds a context that allows for mapping each name to a precise uid, taking
lexical scopes into account *)
open Utils
open Catala_utils
open Shared_ast
(** {1 Name resolution context} *)
type ident = string
module IdentMap : Map.S with type key = String.t
type unique_rulename =
| Ambiguous of Pos.t list
| Unique of RuleName.t Marked.pos
type scope_def_context = {
default_exception_rulename : unique_rulename option;
label_idmap : LabelName.t IdentMap.t;
label_idmap : LabelName.t IdentName.Map.t;
}
type scope_var_or_subscope =
@ -41,26 +37,26 @@ type scope_var_or_subscope =
| SubScope of SubScopeName.t * ScopeName.t
type scope_context = {
var_idmap : scope_var_or_subscope IdentMap.t;
var_idmap : scope_var_or_subscope IdentName.Map.t;
(** All variables, including scope variables and subscopes *)
scope_defs_contexts : scope_def_context Ast.ScopeDefMap.t;
(** What is the default rule to refer to for unnamed exceptions, if any *)
sub_scopes : ScopeSet.t;
sub_scopes : ScopeName.Set.t;
(** Other scopes referred to by this scope. Used for dependency analysis *)
}
(** Inside a scope, we distinguish between the variables and the subscopes. *)
type struct_context = typ StructFieldMap.t
type struct_context = typ StructField.Map.t
(** Types of the fields of a struct *)
type enum_context = typ EnumConstructorMap.t
type enum_context = typ EnumConstructor.Map.t
(** Types of the payloads of the cases of an enum *)
type var_sig = {
var_sig_typ : typ;
var_sig_is_condition : bool;
var_sig_io : Surface.Ast.scope_decl_context_io;
var_sig_states_idmap : StateName.t IdentMap.t;
var_sig_states_idmap : StateName.t IdentName.Map.t;
var_sig_states_list : StateName.t list;
}
@ -73,21 +69,22 @@ type typedef =
(** Implicitly defined output struct *)
type context = {
local_var_idmap : Ast.expr Var.t IdentMap.t;
local_var_idmap : Ast.expr Var.t IdentName.Map.t;
(** Inside a definition, local variables can be introduced by functions
arguments or pattern matching *)
typedefs : typedef IdentMap.t;
typedefs : typedef IdentName.Map.t;
(** Gathers the names of the scopes, structs and enums *)
field_idmap : StructFieldName.t StructMap.t IdentMap.t;
field_idmap : StructField.t StructName.Map.t IdentName.Map.t;
(** The names of the struct fields. Names of fields can be shared between
different structs *)
constructor_idmap : EnumConstructor.t EnumMap.t IdentMap.t;
constructor_idmap : EnumConstructor.t EnumName.Map.t IdentName.Map.t;
(** The names of the enum constructors. Constructor names can be shared
between different enums *)
scopes : scope_context ScopeMap.t; (** For each scope, its context *)
structs : struct_context StructMap.t; (** For each struct, its context *)
enums : enum_context EnumMap.t; (** For each enum, its context *)
var_typs : var_sig ScopeVarMap.t;
scopes : scope_context ScopeName.Map.t; (** For each scope, its context *)
structs : struct_context StructName.Map.t;
(** For each struct, its context *)
enums : enum_context EnumName.Map.t; (** For each enum, its context *)
var_typs : var_sig ScopeVar.Map.t;
(** The signatures of each scope variable declared *)
}
(** Main context used throughout {!module: Surface.Desugaring} *)
@ -98,7 +95,7 @@ val raise_unsupported_feature : string -> Pos.t -> 'a
(** Temporary function raising an error message saying that a feature is not
supported yet *)
val raise_unknown_identifier : string -> ident Marked.pos -> 'a
val raise_unknown_identifier : string -> IdentName.t Marked.pos -> 'a
(** Function to call whenever an identifier used somewhere has not been declared
in the program previously *)
@ -108,14 +105,14 @@ val get_var_typ : context -> ScopeVar.t -> typ
val is_var_cond : context -> ScopeVar.t -> bool
val get_var_io : context -> ScopeVar.t -> Surface.Ast.scope_decl_context_io
val get_var_uid : ScopeName.t -> context -> ident Marked.pos -> ScopeVar.t
val get_var_uid : ScopeName.t -> context -> IdentName.t Marked.pos -> ScopeVar.t
(** Get the variable uid inside the scope given in argument *)
val get_subscope_uid :
ScopeName.t -> context -> ident Marked.pos -> SubScopeName.t
ScopeName.t -> context -> IdentName.t Marked.pos -> SubScopeName.t
(** Get the subscope uid inside the scope given in argument *)
val is_subscope_uid : ScopeName.t -> context -> ident -> bool
val is_subscope_uid : ScopeName.t -> context -> IdentName.t -> bool
(** [is_subscope_uid scope_uid ctxt y] returns true if [y] belongs to the
subscopes of [scope_uid]. *)
@ -128,7 +125,7 @@ val get_def_typ : context -> Ast.ScopeDef.t -> typ
val is_def_cond : context -> Ast.ScopeDef.t -> bool
val is_type_cond : Surface.Ast.typ -> bool
val add_def_local_var : context -> ident -> context * Ast.expr Var.t
val add_def_local_var : context -> IdentName.t -> context * Ast.expr Var.t
(** Adds a binding to the context *)
val get_def_key :
@ -140,15 +137,15 @@ val get_def_key :
Ast.ScopeDef.t
(** Usage: [get_def_key var_name var_state scope_uid ctxt pos]*)
val get_enum : context -> ident Marked.pos -> EnumName.t
val get_enum : context -> IdentName.t Marked.pos -> EnumName.t
(** Find an enum definition from the typedefs, failing if there is none or it
has a different kind *)
val get_struct : context -> ident Marked.pos -> StructName.t
val get_struct : context -> IdentName.t Marked.pos -> StructName.t
(** Find a struct definition from the typedefs (possibly an implicit output
struct from a scope), failing if there is none or it has a different kind *)
val get_scope : context -> ident Marked.pos -> ScopeName.t
val get_scope : context -> IdentName.t Marked.pos -> ScopeName.t
(** Find a scope definition from the typedefs, failing if there is none or it
has a different kind *)

18
compiler/driver.ml
View File

@ -15,10 +15,7 @@
License for the specific language governing permissions and limitations under
the License. *)
module Cli = Utils.Cli
module File = Utils.File
module Errors = Utils.Errors
module Pos = Utils.Pos
open Catala_utils
(** Associates a {!type: Cli.backend_lang} with its string represtation. *)
let languages = ["en", Cli.En; "fr", Cli.Fr; "pl", Cli.Pl]
@ -151,20 +148,18 @@ let driver source_file (options : Cli.options) : int =
| None, _ ->
let _, scope =
try
Desugared.Name_resolution.IdentMap.filter_map
Shared_ast.IdentName.Map.filter_map
(fun _ -> function
| Desugared.Name_resolution.TScope (uid, _) -> Some uid
| _ -> None)
ctxt.typedefs
|> Desugared.Name_resolution.IdentMap.choose
|> Shared_ast.IdentName.Map.choose
with Not_found ->
Errors.raise_error "There isn't any scope inside the program."
in
scope
| Some name, _ -> (
match
Desugared.Name_resolution.IdentMap.find_opt name ctxt.typedefs
with
match Shared_ast.IdentName.Map.find_opt name ctxt.typedefs with
| Some (Desugared.Name_resolution.TScope (uid, _)) -> uid
| _ ->
Errors.raise_error "There is no scope \"%s\" inside the program."
@ -172,6 +167,8 @@ let driver source_file (options : Cli.options) : int =
in
Cli.debug_print "Desugaring...";
let prgm = Desugared.From_surface.translate_program ctxt prgm in
Cli.debug_print "Disambiguating...";
let prgm = Desugared.Disambiguate.program prgm in
Cli.debug_print "Collecting rules...";
let prgm = Scopelang.From_desugared.translate_program prgm in
match backend with
@ -182,7 +179,8 @@ let driver source_file (options : Cli.options) : int =
if Option.is_some options.ex_scope then
Format.fprintf fmt "%a\n"
(Scopelang.Print.scope prgm.program_ctx ~debug:options.debug)
(scope_uid, Shared_ast.ScopeMap.find scope_uid prgm.program_scopes)
( scope_uid,
Shared_ast.ScopeName.Map.find scope_uid prgm.program_scopes )
else
Format.fprintf fmt "%a\n"
(Scopelang.Print.program ~debug:options.debug)

3
compiler/driver.mli
View File

@ -15,9 +15,10 @@
License for the specific language governing permissions and limitations under
the License. *)
open Catala_utils
module Plugin = Plugin.PluginAPI
val driver : Utils.Pos.input_file -> Utils.Cli.options -> int
val driver : Pos.input_file -> Cli.options -> int
(** Entry function for the executable. Returns a negative number in case of
error. *)

2
compiler/dune
View File

@ -3,7 +3,7 @@
(public_name catala.driver)
(libraries
dynlink
utils
catala_utils
surface
desugared
literate

2
compiler/index.mld
View File

@ -103,7 +103,7 @@ Two more modules contain additional features for the compiler:
{ul
{li {{: literate.html} Literate programming}}
{li {{: utils.html} Compiler utilities}}
{li {{: catala_utils.html} Compiler utilities}}
}
The Catala runtimes documentation is available here:

16
compiler/lcalc/ast.ml
View File

@ -14,7 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
include Shared_ast
type lit = lcalc glit
@ -28,10 +28,10 @@ let option_enum : EnumName.t = EnumName.fresh ("eoption", Pos.no_pos)
let none_constr : EnumConstructor.t = EnumConstructor.fresh ("ENone", Pos.no_pos)
let some_constr : EnumConstructor.t = EnumConstructor.fresh ("ESome", Pos.no_pos)
let option_enum_config : typ EnumConstructorMap.t =
EnumConstructorMap.empty
|> EnumConstructorMap.add none_constr (TLit TUnit, Pos.no_pos)
|> EnumConstructorMap.add some_constr (TAny, Pos.no_pos)
let option_enum_config : typ EnumConstructor.Map.t =
EnumConstructor.Map.empty
|> EnumConstructor.Map.add none_constr (TLit TUnit, Pos.no_pos)
|> EnumConstructor.Map.add some_constr (TAny, Pos.no_pos)
(* FIXME: proper typing in all the constructors below *)
@ -49,9 +49,9 @@ let make_some e =
let make_matchopt_with_abs_arms arg e_none e_some =
let m = Marked.get_mark arg in
let cases =
EnumConstructorMap.empty
|> EnumConstructorMap.add none_constr e_none
|> EnumConstructorMap.add some_constr e_some
EnumConstructor.Map.empty
|> EnumConstructor.Map.add none_constr e_none
|> EnumConstructor.Map.add some_constr e_some
in
Expr.ematch arg option_enum cases m

5
compiler/lcalc/ast.mli
View File

@ -14,6 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Catala_utils
open Shared_ast
(** Abstract syntax tree for the lambda calculus *)
@ -32,7 +33,7 @@ type 'm program = 'm expr Shared_ast.program
val option_enum : EnumName.t
val none_constr : EnumConstructor.t
val some_constr : EnumConstructor.t
val option_enum_config : typ EnumConstructorMap.t
val option_enum_config : typ EnumConstructor.Map.t
val make_none : 'm mark -> 'm expr boxed
val make_some : 'm expr boxed -> 'm expr boxed
@ -40,7 +41,7 @@ val make_matchopt_with_abs_arms :
'm expr boxed -> 'm expr boxed -> 'm expr boxed -> 'm expr boxed
val make_matchopt :
Utils.Pos.t ->
Pos.t ->
'm expr Var.t ->
typ ->
'm expr boxed ->

8
compiler/lcalc/closure_conversion.ml
View File

@ -14,7 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
open Shared_ast
open Ast
module D = Dcalc.Ast
@ -44,7 +44,7 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m expr) : m expr boxed =
(* We do not close the clotures inside the arms of the match expression,
since they get a special treatment at compilation to Scalc. *)
let free_vars, new_cases =
EnumConstructorMap.fold
EnumConstructor.Map.fold
(fun cons e1 (free_vars, new_cases) ->
match Marked.unmark e1 with
| EAbs { binder; tys } ->
@ -52,12 +52,12 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m expr) : m expr boxed =
let new_free_vars, new_body = aux body in
let new_binder = Expr.bind vars new_body in
( Var.Set.union free_vars new_free_vars,
EnumConstructorMap.add cons
EnumConstructor.Map.add cons
(Expr.eabs new_binder tys (Marked.get_mark e1))
new_cases )
| _ -> failwith "should not happen")
cases
(free_vars, EnumConstructorMap.empty)
(free_vars, EnumConstructor.Map.empty)
in
free_vars, Expr.ematch new_e name new_cases m
| EApp { f = EAbs { binder; tys }, e1_pos; args } ->

10
compiler/lcalc/compile_with_exceptions.ml
View File

@ -14,7 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
open Shared_ast
module D = Dcalc.Ast
module A = Ast
@ -43,7 +43,7 @@ let rec translate_default
Expr.make_app
(Expr.make_var
(Var.translate A.handle_default)
(Expr.with_ty mark_default (Utils.Marked.mark pos TAny)))
(Expr.with_ty mark_default (Marked.mark pos TAny)))
[
Expr.earray exceptions mark_default;
thunk_expr (translate_expr ctx just);
@ -58,13 +58,13 @@ and translate_expr (ctx : 'm ctx) (e : 'm D.expr) : 'm A.expr boxed =
match Marked.unmark e with
| EVar v -> Expr.make_var (Var.Map.find v ctx) m
| EStruct { name; fields } ->
Expr.estruct name (StructFieldMap.map (translate_expr ctx) fields) m
Expr.estruct name (StructField.Map.map (translate_expr ctx) fields) m
| EStructAccess { name; e; field } ->
Expr.estructaccess (translate_expr ctx e) field name m
| EInj { name; e; cons } -> Expr.einj (translate_expr ctx e) cons name m
| EMatch { name; e; cases } ->
Expr.ematch (translate_expr ctx e) name
(EnumConstructorMap.map (translate_expr ctx) cases)
(EnumConstructor.Map.map (translate_expr ctx) cases)
m
| EArray es -> Expr.earray (List.map (translate_expr ctx) es) m
| ELit
@ -72,7 +72,7 @@ and translate_expr (ctx : 'm ctx) (e : 'm D.expr) : 'm A.expr boxed =
l) ->
Expr.elit l m
| ELit LEmptyError -> Expr.eraise EmptyError m
| EOp op -> Expr.eop op m
| EOp op -> Expr.eop (Expr.translate_op op) m
| EIfThenElse { cond; etrue; efalse } ->
Expr.eifthenelse (translate_expr ctx cond) (translate_expr ctx etrue)
(translate_expr ctx efalse)

23
compiler/lcalc/compile_without_exceptions.ml
View File

@ -14,7 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
module D = Dcalc.Ast
module A = Ast
@ -255,11 +255,12 @@ let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.expr) :
e', hoists
| EStruct { name; fields } ->
let fields', h_fields =
StructFieldMap.fold
StructField.Map.fold
(fun field e (fields, hoists) ->
let e, h = translate_and_hoist ctx e in
StructFieldMap.add field e fields, h :: hoists)
fields (StructFieldMap.empty, [])
StructField.Map.add field e fields, h :: hoists)
fields
(StructField.Map.empty, [])
in
let hoists = disjoint_union_maps (Expr.pos e) h_fields in
Expr.estruct name fields' mark, hoists
@ -274,12 +275,12 @@ let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.expr) :
| EMatch { name; e = e1; cases } ->
let e1', h1 = translate_and_hoist ctx e1 in
let cases', h_cases =
EnumConstructorMap.fold
EnumConstructor.Map.fold
(fun cons e (cases, hoists) ->
let e', h = translate_and_hoist ctx e in
EnumConstructorMap.add cons e' cases, h :: hoists)
EnumConstructor.Map.add cons e' cases, h :: hoists)
cases
(EnumConstructorMap.empty, [])
(EnumConstructor.Map.empty, [])
in
let hoists = disjoint_union_maps (Expr.pos e) (h1 :: h_cases) in
let e' = Expr.ematch e1' name cases' mark in
@ -288,7 +289,7 @@ let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.expr) :
let es', hoists = es |> List.map (translate_and_hoist ctx) |> List.split in
Expr.earray es' mark, disjoint_union_maps (Expr.pos e) hoists
| EOp op -> Expr.eop op mark, Var.Map.empty
| EOp op -> Expr.eop (Expr.translate_op op) mark, Var.Map.empty
and translate_expr ?(append_esome = true) (ctx : 'm ctx) (e : 'm D.expr) :
'm A.expr boxed =
@ -537,7 +538,7 @@ let translate_program (prgm : 'm D.program) : 'm A.program =
prgm.decl_ctx with
ctx_enums =
prgm.decl_ctx.ctx_enums
|> EnumMap.add A.option_enum A.option_enum_config;
|> EnumName.Map.add A.option_enum A.option_enum_config;
}
in
let decl_ctx =
@ -545,9 +546,9 @@ let translate_program (prgm : 'm D.program) : 'm A.program =
decl_ctx with
ctx_structs =
prgm.decl_ctx.ctx_structs
|> StructMap.mapi (fun n str ->
|> StructName.Map.mapi (fun n str ->
if List.mem n inputs_structs then
StructFieldMap.map translate_typ str
StructField.Map.map translate_typ str
(* Cli.debug_print @@ Format.asprintf "Input type: %a"
(Print.typ decl_ctx) tau; Cli.debug_print @@ Format.asprintf
"Output type: %a" (Print.typ decl_ctx) (translate_typ

8
compiler/lcalc/optimizations.ml
View File

@ -13,7 +13,7 @@
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 Utils
open Catala_utils
open Shared_ast
open Ast
module D = Dcalc.Ast
@ -27,16 +27,16 @@ let rec iota_expr (e : 'm expr) : 'm expr boxed =
| EMatch { e = EInj { e = e'; cons; name = n' }, _; cases; name = n }
when EnumName.equal n n' ->
let e1 = visitor_map iota_expr e' in
let case = visitor_map iota_expr (EnumConstructorMap.find cons cases) in
let case = visitor_map iota_expr (EnumConstructor.Map.find cons cases) in
Expr.eapp case [e1] m
| EMatch { e = e'; cases; name = n }
when cases
|> EnumConstructorMap.mapi (fun i case ->
|> EnumConstructor.Map.mapi (fun i case ->
match Marked.unmark case with
| EInj { cons = i'; name = n'; _ } ->
EnumConstructor.equal i i' && EnumName.equal n n'
| _ -> false)
|> EnumConstructorMap.for_all (fun _ b -> b) ->
|> EnumConstructor.Map.for_all (fun _ b -> b) ->
visitor_map iota_expr e'
| _ -> visitor_map iota_expr e

74
compiler/lcalc/to_ocaml.ml
View File

@ -14,22 +14,21 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
open Shared_ast
open Ast
open String_common
module D = Dcalc.Ast
let find_struct (s : StructName.t) (ctx : decl_ctx) : typ StructFieldMap.t =
try StructMap.find s ctx.ctx_structs
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
Errors.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 EnumConstructorMap.t =
try EnumMap.find en ctx.ctx_enums
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
Errors.raise_spanned_error pos
@ -55,7 +54,7 @@ let format_lit (fmt : Format.formatter) (l : lit Marked.pos) : unit =
let years, months, days = Runtime.duration_to_years_months_days d in
Format.fprintf fmt "duration_of_numbers (%d) (%d) (%d)" years months days
let format_op_kind (fmt : Format.formatter) (k : op_kind) =
let format_op_kind (fmt : Format.formatter) (k : 'a op_kind) =
Format.fprintf fmt "%s"
(match k with
| KInt -> "!"
@ -64,7 +63,7 @@ let format_op_kind (fmt : Format.formatter) (k : op_kind) =
| KDate -> "@"
| KDuration -> "^")
let format_binop (fmt : Format.formatter) (op : binop Marked.pos) : unit =
let format_binop (fmt : Format.formatter) (op : 'a binop Marked.pos) : unit =
match Marked.unmark op with
| Add k -> Format.fprintf fmt "+%a" format_op_kind k
| Sub k -> Format.fprintf fmt "-%a" format_op_kind k
@ -91,7 +90,7 @@ let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@ ")
(fun fmt info ->
Format.fprintf fmt "\"%a\"" Utils.Uid.MarkedString.format_info info))
Format.fprintf fmt "\"%a\"" Uid.MarkedString.format info))
uids
let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
@ -104,7 +103,7 @@ let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
(Re.replace sanitize_quotes ~f:(fun _ -> "\\\"") info)))
uids
let format_unop (fmt : Format.formatter) (op : unop Marked.pos) : unit =
let format_unop (fmt : Format.formatter) (op : lcalc unop Marked.pos) : unit =
match Marked.unmark op with
| Minus k -> Format.fprintf fmt "~-%a" format_op_kind k
| Not -> Format.fprintf fmt "%s" "not"
@ -141,8 +140,8 @@ let avoid_keywords (s : string) : string =
let format_struct_name (fmt : Format.formatter) (v : StructName.t) : unit =
Format.asprintf "%a" StructName.format_t v
|> to_ascii
|> to_snake_case
|> String.to_ascii
|> String.to_snake_case
|> avoid_keywords
|> Format.fprintf fmt "%s"
@ -152,8 +151,8 @@ let format_to_module_name
(match name with
| `Ename v -> Format.asprintf "%a" EnumName.format_t v
| `Sname v -> Format.asprintf "%a" StructName.format_t v)
|> to_ascii
|> to_snake_case
|> String.to_ascii
|> String.to_snake_case
|> avoid_keywords
|> String.split_on_char '_'
|> List.map String.capitalize_ascii
@ -162,24 +161,25 @@ let format_to_module_name
let format_struct_field_name
(fmt : Format.formatter)
((sname_opt, v) : StructName.t option * StructFieldName.t) : unit =
((sname_opt, v) : StructName.t option * StructField.t) : unit =
(match sname_opt with
| Some sname ->
Format.fprintf fmt "%a.%s" format_to_module_name (`Sname sname)
| None -> Format.fprintf fmt "%s")
(avoid_keywords
(to_ascii (Format.asprintf "%a" StructFieldName.format_t v)))
(String.to_ascii (Format.asprintf "%a" StructField.format_t v)))
let format_enum_name (fmt : Format.formatter) (v : EnumName.t) : unit =
Format.fprintf fmt "%s"
(avoid_keywords
(to_snake_case (to_ascii (Format.asprintf "%a" EnumName.format_t v))))
(String.to_snake_case
(String.to_ascii (Format.asprintf "%a" EnumName.format_t v))))
let format_enum_cons_name (fmt : Format.formatter) (v : EnumConstructor.t) :
unit =
Format.fprintf fmt "%s"
(avoid_keywords
(to_ascii (Format.asprintf "%a" EnumConstructor.format_t v)))
(String.to_ascii (Format.asprintf "%a" EnumConstructor.format_t v)))
let rec typ_embedding_name (fmt : Format.formatter) (ty : typ) : unit =
match Marked.unmark ty with
@ -223,16 +223,18 @@ let rec format_typ (fmt : Format.formatter) (typ : typ) : unit =
| TAny -> Format.fprintf fmt "_"
let format_var (fmt : Format.formatter) (v : 'm Var.t) : unit =
let lowercase_name = to_snake_case (to_ascii (Bindlib.name_of v)) in
let lowercase_name =
String.to_snake_case (String.to_ascii (Bindlib.name_of v))
in
let lowercase_name =
Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.")
~subst:(fun _ -> "_dot_")
lowercase_name
in
let lowercase_name = avoid_keywords (to_ascii lowercase_name) in
let lowercase_name = avoid_keywords (String.to_ascii lowercase_name) in
if
List.mem lowercase_name ["handle_default"; "handle_default_opt"]
|| begins_with_uppercase (Bindlib.name_of v)
|| String.begins_with_uppercase (Bindlib.name_of v)
then Format.fprintf fmt "%s" lowercase_name
else if lowercase_name = "_" then Format.fprintf fmt "%s" lowercase_name
else (
@ -284,7 +286,7 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
(fun fmt e -> Format.fprintf fmt "%a" format_with_parens e))
es
| EStruct { name = s; fields = es } ->
if StructFieldMap.is_empty es then Format.fprintf fmt "()"
if StructField.Map.is_empty es then Format.fprintf fmt "()"
else
Format.fprintf fmt "{@[<hov 2>%a@]}"
(Format.pp_print_list
@ -292,7 +294,7 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
(fun fmt (struct_field, e) ->
Format.fprintf fmt "@[<hov 2>%a =@ %a@]" format_struct_field_name
(Some s, struct_field) format_with_parens e))
(StructFieldMap.bindings es)
(StructField.Map.bindings es)
| EArray es ->
Format.fprintf fmt "@[<hov 2>[|%a|]@]"
(Format.pp_print_list
@ -331,7 +333,7 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
| _ -> assert false
(* should not happen *))
e))
(EnumConstructorMap.bindings cases)
(EnumConstructor.Map.bindings cases)
| ELit l -> Format.fprintf fmt "%a" format_lit (Marked.mark (Expr.pos e) l)
| EApp { f = EAbs { binder; tys }, _; args } ->
let xs, body = Bindlib.unmbind binder in
@ -444,8 +446,8 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
let format_struct_embedding
(fmt : Format.formatter)
((struct_name, struct_fields) : StructName.t * typ StructFieldMap.t) =
if StructFieldMap.is_empty struct_fields then
((struct_name, struct_fields) : StructName.t * typ StructField.Map.t) =
if StructField.Map.is_empty struct_fields then
Format.fprintf fmt "let embed_%a (_: %a.t) : runtime_value = Unit@\n@\n"
format_struct_name struct_name format_to_module_name (`Sname struct_name)
else
@ -458,16 +460,16 @@ let format_struct_embedding
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n")
(fun _fmt (struct_field, struct_field_type) ->
Format.fprintf fmt "(\"%a\",@ %a@ x.%a)" StructFieldName.format_t
Format.fprintf fmt "(\"%a\",@ %a@ x.%a)" StructField.format_t
struct_field typ_embedding_name struct_field_type
format_struct_field_name
(Some struct_name, struct_field)))
(StructFieldMap.bindings struct_fields)
(StructField.Map.bindings struct_fields)
let format_enum_embedding
(fmt : Format.formatter)
((enum_name, enum_cases) : EnumName.t * typ EnumConstructorMap.t) =
if EnumConstructorMap.is_empty enum_cases then
((enum_name, enum_cases) : EnumName.t * typ EnumConstructor.Map.t) =
if EnumConstructor.Map.is_empty enum_cases then
Format.fprintf fmt "let embed_%a (_: %a.t) : runtime_value = Unit@\n@\n"
format_to_module_name (`Ename enum_name) format_enum_name enum_name
else
@ -483,14 +485,14 @@ let format_enum_embedding
Format.fprintf fmt "@[<hov 2>| %a x ->@ (\"%a\", %a x)@]"
format_enum_cons_name enum_cons EnumConstructor.format_t enum_cons
typ_embedding_name enum_cons_type))
(EnumConstructorMap.bindings enum_cases)
(EnumConstructor.Map.bindings enum_cases)
let format_ctx
(type_ordering : Scopelang.Dependency.TVertex.t list)
(fmt : Format.formatter)
(ctx : decl_ctx) : unit =
let format_struct_decl fmt (struct_name, struct_fields) =
if StructFieldMap.is_empty struct_fields then
if StructField.Map.is_empty struct_fields then
Format.fprintf fmt
"@[<v 2>module %a = struct@\n@[<hov 2>type t = unit@]@]@\nend@\n"
format_to_module_name (`Sname struct_name)
@ -505,7 +507,7 @@ let format_ctx
(fun _fmt (struct_field, struct_field_type) ->
Format.fprintf fmt "@[<hov 2>%a:@ %a@]" format_struct_field_name
(None, struct_field) format_typ struct_field_type))
(StructFieldMap.bindings struct_fields);
(StructField.Map.bindings struct_fields);
if !Cli.trace_flag then
format_struct_embedding fmt (struct_name, struct_fields)
in
@ -518,7 +520,7 @@ let format_ctx
(fun _fmt (enum_cons, enum_cons_type) ->
Format.fprintf fmt "@[<hov 2>| %a@ of@ %a@]" format_enum_cons_name
enum_cons format_typ enum_cons_type))
(EnumConstructorMap.bindings enum_cons);
(EnumConstructor.Map.bindings enum_cons);
if !Cli.trace_flag then format_enum_embedding fmt (enum_name, enum_cons)
in
let is_in_type_ordering s =
@ -532,8 +534,8 @@ let format_ctx
let scope_structs =
List.map
(fun (s, _) -> Scopelang.Dependency.TVertex.Struct s)
(StructMap.bindings
(StructMap.filter
(StructName.Map.bindings
(StructName.Map.filter
(fun s _ -> not (is_in_type_ordering s))
ctx.ctx_structs))
in

6
compiler/lcalc/to_ocaml.mli
View File

@ -19,8 +19,8 @@ open Shared_ast
(** Formats a lambda calculus program into a valid OCaml program *)
val avoid_keywords : string -> string
val find_struct : StructName.t -> decl_ctx -> typ StructFieldMap.t
val find_enum : EnumName.t -> decl_ctx -> typ EnumConstructorMap.t
val find_struct : StructName.t -> decl_ctx -> typ StructField.Map.t
val find_enum : EnumName.t -> decl_ctx -> typ EnumConstructor.Map.t
val typ_needs_parens : typ -> bool
(* val needs_parens : 'm expr -> bool *)
@ -29,7 +29,7 @@ val format_enum_cons_name : Format.formatter -> EnumConstructor.t -> unit
val format_struct_name : Format.formatter -> StructName.t -> unit
val format_struct_field_name :
Format.formatter -> StructName.t option * StructFieldName.t -> unit
Format.formatter -> StructName.t option * StructField.t -> unit
val format_to_module_name :
Format.formatter -> [< `Ename of EnumName.t | `Sname of StructName.t ] -> unit

2
compiler/literate/dune
View File

@ -1,7 +1,7 @@
(library
(name literate)
(public_name catala.literate)
(libraries re utils surface ubase))
(libraries re catala_utils surface ubase))
(documentation
(package catala)

8
compiler/literate/html.ml
View File

@ -18,7 +18,7 @@
(** This modules weaves the source code and the legislative text together into a
document that law professionals can understand. *)
open Utils
open Catala_utils
open Literate_common
module A = Surface.Ast
module P = Printf
@ -91,7 +91,7 @@ let wrap_html
</ul>\n"
css_as_string (literal_title language)
(literal_generated_by language)
Utils.Cli.version
Cli.version
(pre_html (literal_disclaimer_and_link language))
(literal_source_files language)
(String.concat "\n"
@ -133,7 +133,7 @@ let pygmentize_code (c : string Marked.pos) (language : C.backend_lang) : string
"html";
"-O";
"style=colorful,anchorlinenos=True,lineanchors=\""
^ String_common.to_ascii (Pos.get_file (Marked.get_mark c))
^ String.to_ascii (Pos.get_file (Marked.get_mark c))
^ "\",linenos=table,linenostart="
^ string_of_int (Pos.get_start_line (Marked.get_mark c));
"-o";
@ -160,7 +160,7 @@ let pygmentize_code (c : string Marked.pos) (language : C.backend_lang) : string
let sanitize_html_href str =
str
|> String_common.to_ascii
|> String.to_ascii
|> R.substitute ~rex:(R.regexp "[' '°\"]") ~subst:(function _ -> "%20")
let rec law_structure_to_html

2
compiler/literate/html.mli
View File

@ -17,7 +17,7 @@
(** This modules weaves the source code and the legislative text together into a
document that law professionals can understand. *)
open Utils
open Catala_utils
(** {1 Helpers} *)

4
compiler/literate/latex.ml
View File

@ -18,7 +18,7 @@
(** This modules weaves the source code and the legislative text together into a
document that law professionals can understand. *)
open Utils
open Catala_utils
open Literate_common
module A = Surface.Ast
module R = Re.Pcre
@ -158,7 +158,7 @@ codes={\catcode`\$=3\catcode`\^=7}
https://gouvfr.atlassian.net/wiki/spaces/DB/pages/223019527/Typographie+-+Typography *)
(literal_title language)
(literal_generated_by language)
Utils.Cli.version
Cli.version
(pre_latexify (literal_disclaimer_and_link language))
(literal_source_files language)
(String.concat

2
compiler/literate/latex.mli
View File

@ -17,7 +17,7 @@
(** This modules weaves the source code and the legislative text together into a
document that law professionals can understand. *)
open Utils
open Catala_utils
(** {1 Helpers} *)

2
compiler/literate/literate_common.ml
View File

@ -14,7 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
open Cli
let literal_title = function

16
compiler/literate/literate_common.mli
View File

@ -14,32 +14,30 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
val literal_title : Cli.backend_lang -> string
(** Return the title traduction according the given
{!type:Utils.Cli.backend_lang}. *)
(** Return the title traduction according the given {!type:Cli.backend_lang}. *)
val literal_generated_by : Cli.backend_lang -> string
(** Return the 'generated by' traduction according the given
{!type:Utils.Cli.backend_lang}. *)
{!type:Cli.backend_lang}. *)
val literal_source_files : Cli.backend_lang -> string
(** Return the 'source files weaved' traduction according the given
{!type:Utils.Cli.backend_lang}. *)
{!type:Cli.backend_lang}. *)
val literal_disclaimer_and_link : Cli.backend_lang -> string
(** Return the traduction of a paragraph giving a basic disclaimer about Catala
and a link to the website according the given {!type:
Utils.Cli.backend_lang}. *)
and a link to the website according the given {!type: Cli.backend_lang}. *)
val literal_last_modification : Cli.backend_lang -> string
(** Return the 'last modification' traduction according the given
{!type:Utils.Cli.backend_lang}. *)
{!type:Cli.backend_lang}. *)
val get_language_extension : Cli.backend_lang -> string
(** Return the file extension corresponding to the given
{!type:Utils.Cli.backend_lang}. *)
{!type:Cli.backend_lang}. *)
val run_pandoc : string -> [ `Html | `Latex ] -> string
(** Runs the [pandoc] on a string to pretty-print markdown features into the

8
compiler/plugin.ml
View File

@ -14,8 +14,10 @@
License for the specific language governing permissions and limitations under
the License. *)
open Catala_utils
type 'ast plugin_apply_fun_typ =
source_file:Utils.Pos.input_file ->
source_file:Pos.input_file ->
output_file:string option ->
scope:string option ->
'ast ->
@ -51,9 +53,9 @@ let find name = Hashtbl.find backend_plugins (String.lowercase_ascii name)
let load_file f =
try
Dynlink.loadfile f;
Utils.Cli.debug_print "Plugin %S loaded" f
Cli.debug_print "Plugin %S loaded" f
with e ->
Utils.Errors.format_warning "Could not load plugin %S: %s" f
Errors.format_warning "Could not load plugin %S: %s" f
(Printexc.to_string e)
let load_dir d =

4
compiler/plugin.mli
View File

@ -16,8 +16,10 @@
(** {2 catala-facing API} *)
open Catala_utils
type 'ast plugin_apply_fun_typ =
source_file:Utils.Pos.input_file ->
source_file:Pos.input_file ->
output_file:string option ->
scope:string option ->
'ast ->

39
compiler/plugins/api_web.ml
View File

@ -18,9 +18,8 @@
(** Catala plugin for generating web APIs. It generates OCaml code before the
the associated [js_of_ocaml] wrapper. *)
open Utils
open Catala_utils
open Shared_ast
open String_common
open Lcalc
open Lcalc.Ast
open Lcalc.To_ocaml
@ -40,11 +39,11 @@ module To_jsoo = struct
let format_struct_field_name_camel_case
(fmt : Format.formatter)
(v : StructFieldName.t) : unit =
(v : StructField.t) : unit =
let s =
Format.asprintf "%a" StructFieldName.format_t v
|> to_ascii
|> to_snake_case
Format.asprintf "%a" StructField.format_t v
|> String.to_ascii
|> String.to_snake_case
|> avoid_keywords
|> to_camel_case
in
@ -118,17 +117,17 @@ module To_jsoo = struct
let format_var_camel_case (fmt : Format.formatter) (v : 'm Var.t) : unit =
let lowercase_name =
Bindlib.name_of v
|> to_ascii
|> to_snake_case
|> String.to_ascii
|> String.to_snake_case
|> Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.") ~subst:(fun _ ->
"_dot_")
|> to_ascii
|> String.to_ascii
|> avoid_keywords
|> to_camel_case
in
if
List.mem lowercase_name ["handle_default"; "handle_default_opt"]
|| begins_with_uppercase (Bindlib.name_of v)
|| String.begins_with_uppercase (Bindlib.name_of v)
then Format.fprintf fmt "%s" lowercase_name
else if lowercase_name = "_" then Format.fprintf fmt "%s" lowercase_name
else Format.fprintf fmt "%s_" lowercase_name
@ -166,7 +165,7 @@ module To_jsoo = struct
format_struct_field_name_camel_case struct_field
format_typ_to_jsoo struct_field_type fmt_struct_name ()
format_struct_field_name (None, struct_field)))
(StructFieldMap.bindings struct_fields)
(StructField.Map.bindings struct_fields)
in
let fmt_of_jsoo fmt _ =
Format.fprintf fmt "%a"
@ -186,7 +185,7 @@ module To_jsoo = struct
format_struct_field_name (None, struct_field)
format_typ_of_jsoo struct_field_type fmt_struct_name ()
format_struct_field_name_camel_case struct_field))
(StructFieldMap.bindings struct_fields)
(StructField.Map.bindings struct_fields)
in
let fmt_conv_funs fmt _ =
Format.fprintf fmt
@ -203,7 +202,7 @@ module To_jsoo = struct
() fmt_struct_name () fmt_module_struct_name () fmt_of_jsoo ()
in
if StructFieldMap.is_empty struct_fields then
if StructField.Map.is_empty struct_fields then
Format.fprintf fmt
"class type %a =@ object end@\n\
let %a_to_jsoo (_ : %a.t) : %a Js.t = object%%js end@\n\
@ -220,10 +219,10 @@ module To_jsoo = struct
Format.fprintf fmt "@[<hov 2>method %a:@ %a %a@]"
format_struct_field_name_camel_case struct_field format_typ
struct_field_type format_prop_or_meth struct_field_type))
(StructFieldMap.bindings struct_fields)
(StructField.Map.bindings struct_fields)
fmt_conv_funs ()
in
let format_enum_decl fmt (enum_name, (enum_cons : typ EnumConstructorMap.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_module_enum_name fmt _ =
@ -247,7 +246,7 @@ module To_jsoo = struct
end@]"
format_enum_cons_name cname format_enum_cons_name cname
format_typ_to_jsoo typ))
(EnumConstructorMap.bindings enum_cons)
(EnumConstructor.Map.bindings enum_cons)
in
let fmt_of_jsoo fmt _ =
Format.fprintf fmt
@ -273,7 +272,7 @@ module To_jsoo = struct
format_enum_cons_name cname fmt_module_enum_name ()
format_enum_cons_name cname format_typ_of_jsoo typ
fmt_enum_name ()))
(EnumConstructorMap.bindings enum_cons)
(EnumConstructor.Map.bindings enum_cons)
fmt_module_enum_name ()
in
@ -302,7 +301,7 @@ module To_jsoo = struct
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (enum_cons, _) ->
Format.fprintf fmt "- \"%a\"" format_enum_cons_name enum_cons))
(EnumConstructorMap.bindings enum_cons)
(EnumConstructor.Map.bindings enum_cons)
fmt_conv_funs ()
in
let is_in_type_ordering s =
@ -316,8 +315,8 @@ module To_jsoo = struct
let scope_structs =
List.map
(fun (s, _) -> Scopelang.Dependency.TVertex.Struct s)
(StructMap.bindings
(StructMap.filter
(StructName.Map.bindings
(StructName.Map.filter
(fun s _ -> not (is_in_type_ordering s))
ctx.ctx_structs))
in

22
compiler/plugins/json_schema.ml
View File

@ -20,8 +20,7 @@
let name = "json_schema"
let extension = "_schema.json"
open Utils
open String_common
open Catala_utils
open Shared_ast
open Lcalc.Ast
open Lcalc.To_ocaml
@ -38,11 +37,11 @@ module To_json = struct
let format_struct_field_name_camel_case
(fmt : Format.formatter)
(v : StructFieldName.t) : unit =
(v : StructField.t) : unit =
let s =
Format.asprintf "%a" StructFieldName.format_t v
|> to_ascii
|> to_snake_case
Format.asprintf "%a" StructField.format_t v
|> String.to_ascii
|> String.to_snake_case
|> avoid_keywords
|> to_camel_case
in
@ -97,7 +96,7 @@ module To_json = struct
(fun fmt (field_name, field_type) ->
Format.fprintf fmt "@[<hov 2>\"%a\": {@\n%a@]@\n}"
format_struct_field_name_camel_case field_name fmt_type field_type))
(StructFieldMap.bindings (find_struct sname ctx))
(StructField.Map.bindings (find_struct sname ctx))
let fmt_definitions
(ctx : decl_ctx)
@ -119,12 +118,13 @@ module To_json = struct
| TEnum e ->
List.fold_left collect (t :: acc)
(List.map snd
(EnumConstructorMap.bindings (EnumMap.find e ctx.ctx_enums)))
(EnumConstructor.Map.bindings
(EnumName.Map.find e ctx.ctx_enums)))
| TArray t -> collect acc t
| _ -> acc
in
find_struct input_struct ctx
|> StructFieldMap.bindings
|> StructField.Map.bindings
|> List.fold_left (fun acc (_, field_typ) -> collect acc field_typ) []
|> List.sort_uniq (fun t t' -> String.compare (get_name t) (get_name t'))
in
@ -148,7 +148,7 @@ module To_json = struct
Format.fprintf fmt
"@[<hov 2>{@\n\"type\": \"string\",@\n\"enum\": [\"%a\"]@]@\n}"
format_enum_cons_name enum_cons))
(EnumConstructorMap.bindings enum_def)
(EnumConstructor.Map.bindings enum_def)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n")
(fun fmt (enum_cons, payload_type) ->
@ -170,7 +170,7 @@ module To_json = struct
}@]@\n\
}"
format_enum_cons_name enum_cons fmt_type payload_type))
(EnumConstructorMap.bindings enum_def)
(EnumConstructor.Map.bindings enum_def)
in
Format.fprintf fmt "@\n%a"

4
compiler/plugins/python.ml
View File

@ -20,13 +20,15 @@
The code for the Python backend already has first-class support, so there
would be no reason to use this plugin instead *)
open Catala_utils
let name = "python-plugin"
let extension = ".py"
let apply ~source_file ~output_file ~scope prgm type_ordering =
ignore source_file;
ignore scope;
Utils.File.with_formatter_of_opt_file output_file
File.with_formatter_of_opt_file output_file
@@ fun fmt -> Scalc.To_python.format_program fmt prgm type_ordering
let () = Driver.Plugin.register_scalc ~name ~extension apply

6
compiler/scalc/ast.ml
View File

@ -14,7 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
open Shared_ast
module D = Dcalc.Ast
module L = Lcalc.Ast
@ -31,12 +31,12 @@ and naked_expr =
| EVar of LocalName.t
| EFunc of TopLevelName.t
| EStruct of expr list * StructName.t
| EStructFieldAccess of expr * StructFieldName.t * StructName.t
| EStructFieldAccess of expr * StructField.t * StructName.t
| EInj of expr * EnumConstructor.t * EnumName.t
| EArray of expr list
| ELit of L.lit
| EApp of expr * expr list
| EOp of operator
| EOp of lcalc operator
type stmt =
| SInnerFuncDef of LocalName.t Marked.pos * func

6
compiler/scalc/compile_from_lambda.ml
View File

@ -14,7 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
open Shared_ast
module A = Ast
module L = Lcalc.Ast
@ -48,7 +48,7 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
[], (local_var, Expr.pos expr)
| EStruct { fields; name } ->
let args_stmts, new_args =
StructFieldMap.fold
StructField.Map.fold
(fun _ arg (args_stmts, new_args) ->
let arg_stmts, new_arg = translate_expr ctxt arg in
arg_stmts @ args_stmts, new_arg :: new_args)
@ -207,7 +207,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
| EMatch { e = e1; cases; name } ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
let new_cases =
EnumConstructorMap.fold
EnumConstructor.Map.fold
(fun _ arg new_args ->
match Marked.unmark arg with
| EAbs { binder; _ } ->

12
compiler/scalc/print.ml
View File

@ -14,7 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
open Shared_ast
open Ast
@ -46,10 +46,10 @@ let rec format_expr
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt (e, (struct_field, _)) ->
Format.fprintf fmt "%a%a%a%a %a" Print.punctuation "\""
StructFieldName.format_t struct_field Print.punctuation "\""
StructField.format_t struct_field Print.punctuation "\""
Print.punctuation ":" format_expr e))
(List.combine es
(StructFieldMap.bindings (StructMap.find s decl_ctx.ctx_structs)))
(StructField.Map.bindings (StructName.Map.find s decl_ctx.ctx_structs)))
Print.punctuation "}"
| EArray es ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" Print.punctuation "["
@ -59,8 +59,7 @@ let rec format_expr
es Print.punctuation "]"
| EStructFieldAccess (e1, field, _) ->
Format.fprintf fmt "%a%a%a%a%a" format_expr e1 Print.punctuation "."
Print.punctuation "\"" StructFieldName.format_t field Print.punctuation
"\""
Print.punctuation "\"" StructField.format_t field Print.punctuation "\""
| EInj (e, cons, _) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" Print.enum_constructor cons
format_expr e
@ -153,7 +152,8 @@ let rec format_statement
(format_block decl_ctx ~debug)
arm_block))
(List.combine
(EnumConstructorMap.bindings (EnumMap.find enum decl_ctx.ctx_enums))
(EnumConstructor.Map.bindings
(EnumName.Map.find enum decl_ctx.ctx_enums))
arms)
and format_block

51
compiler/scalc/to_python.ml
View File

@ -15,10 +15,9 @@
the License. *)
[@@@warning "-32-27"]
open Utils
open Catala_utils
open Shared_ast
open Ast
open String_common
module Runtime = Runtime_ocaml.Runtime
module D = Dcalc.Ast
module L = Lcalc.Ast
@ -50,7 +49,7 @@ let format_log_entry (fmt : Format.formatter) (entry : log_entry) : unit =
| EndCall -> Format.fprintf fmt "%s" "← "
| PosRecordIfTrueBool -> Format.fprintf fmt "☛ "
let format_binop (fmt : Format.formatter) (op : binop Marked.pos) : unit =
let format_binop (fmt : Format.formatter) (op : lcalc binop Marked.pos) : unit =
match Marked.unmark op with
| Add _ | Concat -> Format.fprintf fmt "+"
| Sub _ -> Format.fprintf fmt "-"
@ -77,7 +76,7 @@ let format_uid_list (fmt : Format.formatter) (uids : Uid.MarkedString.info list)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt info ->
Format.fprintf fmt "\"%a\"" Utils.Uid.MarkedString.format_info info))
Format.fprintf fmt "\"%a\"" Uid.MarkedString.format info))
uids
let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
@ -90,7 +89,7 @@ let format_string_list (fmt : Format.formatter) (uids : string list) : unit =
(Re.replace sanitize_quotes ~f:(fun _ -> "\\\"") info)))
uids
let format_unop (fmt : Format.formatter) (op : unop Marked.pos) : unit =
let format_unop (fmt : Format.formatter) (op : lcalc unop Marked.pos) : unit =
match Marked.unmark op with
| Minus _ -> Format.fprintf fmt "-"
| Not -> Format.fprintf fmt "not"
@ -125,24 +124,26 @@ let avoid_keywords (s : string) : string =
let format_struct_name (fmt : Format.formatter) (v : StructName.t) : unit =
Format.fprintf fmt "%s"
(avoid_keywords
(to_camel_case (to_ascii (Format.asprintf "%a" StructName.format_t v))))
(String.to_camel_case
(String.to_ascii (Format.asprintf "%a" StructName.format_t v))))
let format_struct_field_name (fmt : Format.formatter) (v : StructFieldName.t) :
unit =
let format_struct_field_name (fmt : Format.formatter) (v : StructField.t) : unit
=
Format.fprintf fmt "%s"
(avoid_keywords
(to_ascii (Format.asprintf "%a" StructFieldName.format_t v)))
(String.to_ascii (Format.asprintf "%a" StructField.format_t v)))
let format_enum_name (fmt : Format.formatter) (v : EnumName.t) : unit =
Format.fprintf fmt "%s"
(avoid_keywords
(to_camel_case (to_ascii (Format.asprintf "%a" EnumName.format_t v))))
(String.to_camel_case
(String.to_ascii (Format.asprintf "%a" EnumName.format_t v))))
let format_enum_cons_name (fmt : Format.formatter) (v : EnumConstructor.t) :
unit =
Format.fprintf fmt "%s"
(avoid_keywords
(to_ascii (Format.asprintf "%a" EnumConstructor.format_t v)))
(String.to_ascii (Format.asprintf "%a" EnumConstructor.format_t v)))
let typ_needs_parens (e : typ) : bool =
match Marked.unmark e with TArrow _ | TArray _ -> true | _ -> false
@ -180,10 +181,10 @@ let rec format_typ (fmt : Format.formatter) (typ : typ) : unit =
let format_name_cleaned (fmt : Format.formatter) (s : string) : unit =
s
|> to_ascii
|> to_snake_case
|> String.to_ascii
|> String.to_snake_case
|> Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.") ~subst:(fun _ -> "_dot_")
|> to_ascii
|> String.to_ascii
|> avoid_keywords
|> Format.fprintf fmt "%s"
@ -272,7 +273,7 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
Format.fprintf fmt "%a = %a" format_struct_field_name struct_field
(format_expression ctx) e))
(List.combine es
(StructFieldMap.bindings (StructMap.find s ctx.ctx_structs)))
(StructField.Map.bindings (StructName.Map.find s ctx.ctx_structs)))
| EStructFieldAccess (e1, field, _) ->
Format.fprintf fmt "%a.%a" (format_expression ctx) e1
format_struct_field_name field
@ -401,7 +402,7 @@ let rec format_statement
List.map2
(fun (x, y) (cons, _) -> x, y, cons)
cases
(EnumConstructorMap.bindings (EnumMap.find e_name ctx.ctx_enums))
(EnumConstructor.Map.bindings (EnumName.Map.find e_name ctx.ctx_enums))
in
let tmp_var = LocalName.fresh ("match_arg", Pos.no_pos) in
Format.fprintf fmt "%a = %a@\n@[<hov 4>if %a@]" format_var tmp_var
@ -443,7 +444,7 @@ let format_ctx
(fmt : Format.formatter)
(ctx : decl_ctx) : unit =
let format_struct_decl fmt (struct_name, struct_fields) =
let fields = StructFieldMap.bindings struct_fields in
let fields = StructField.Map.bindings struct_fields in
Format.fprintf fmt
"class %a:@\n\
\ def __init__(self, %a) -> None:@\n\
@ -467,7 +468,7 @@ let format_ctx
Format.fprintf fmt "%a: %a" format_struct_field_name struct_field
format_typ struct_field_type))
fields
(if StructFieldMap.is_empty struct_fields then fun fmt _ ->
(if StructField.Map.is_empty struct_fields then fun fmt _ ->
Format.fprintf fmt " pass"
else
Format.pp_print_list
@ -476,7 +477,7 @@ let format_ctx
Format.fprintf fmt " self.%a = %a" format_struct_field_name
struct_field format_struct_field_name struct_field))
fields format_struct_name struct_name
(if not (StructFieldMap.is_empty struct_fields) then
(if not (StructField.Map.is_empty struct_fields) then
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " and@ ")
(fun fmt (struct_field, _) ->
@ -496,7 +497,7 @@ let format_ctx
fields
in
let format_enum_decl fmt (enum_name, enum_cons) =
if EnumConstructorMap.is_empty enum_cons then
if EnumConstructor.Map.is_empty enum_cons then
failwith "no constructors in the enum"
else
Format.fprintf fmt
@ -529,7 +530,7 @@ let format_ctx
Format.fprintf fmt "%a = %d" format_enum_cons_name enum_cons i))
(List.mapi
(fun i (x, y) -> i, x, y)
(EnumConstructorMap.bindings enum_cons))
(EnumConstructor.Map.bindings enum_cons))
format_enum_name enum_name format_enum_name enum_name format_enum_name
enum_name
in
@ -545,8 +546,8 @@ let format_ctx
let scope_structs =
List.map
(fun (s, _) -> Scopelang.Dependency.TVertex.Struct s)
(StructMap.bindings
(StructMap.filter
(StructName.Map.bindings
(StructName.Map.filter
(fun s _ -> not (is_in_type_ordering s))
ctx.ctx_structs))
in
@ -555,10 +556,10 @@ let format_ctx
match struct_or_enum with
| Scopelang.Dependency.TVertex.Struct s ->
Format.fprintf fmt "%a@\n@\n" format_struct_decl
(s, StructMap.find s ctx.ctx_structs)
(s, StructName.Map.find s ctx.ctx_structs)
| Scopelang.Dependency.TVertex.Enum e ->
Format.fprintf fmt "%a@\n@\n" format_enum_decl
(e, EnumMap.find e ctx.ctx_enums))
(e, EnumName.Map.find e ctx.ctx_enums))
(type_ordering @ scope_structs)
let format_program

14
compiler/scopelang/ast.ml
View File

@ -14,7 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
open Shared_ast
type location = scopelang glocation
@ -46,13 +46,13 @@ type 'm rule =
type 'm scope_decl = {
scope_decl_name : ScopeName.t;
scope_sig : (typ * Desugared.Ast.io) ScopeVarMap.t;
scope_sig : (typ * Desugared.Ast.io) ScopeVar.Map.t;
scope_decl_rules : 'm rule list;
scope_mark : 'm mark;
}
type 'm program = {
program_scopes : 'm scope_decl ScopeMap.t;
program_scopes : 'm scope_decl ScopeName.Map.t;
program_ctx : decl_ctx;
}
@ -70,17 +70,17 @@ let type_rule decl_ctx env = function
let type_program (prg : 'm program) : typed program =
let typing_env =
ScopeMap.fold
ScopeName.Map.fold
(fun scope_name scope_decl ->
let vars = ScopeVarMap.map fst scope_decl.scope_sig in
let vars = ScopeVar.Map.map fst scope_decl.scope_sig in
Typing.Env.add_scope scope_name ~vars)
prg.program_scopes Typing.Env.empty
in
let program_scopes =
ScopeMap.map
ScopeName.Map.map
(fun scope_decl ->
let typing_env =
ScopeVarMap.fold
ScopeVar.Map.fold
(fun svar (typ, _) env -> Typing.Env.add_scope_var svar typ env)
scope_decl.scope_sig typing_env
in

6
compiler/scopelang/ast.mli
View File

@ -16,7 +16,7 @@
(** Abstract syntax tree of the scope language *)
open Utils
open Catala_utils
open Shared_ast
(** {1 Identifiers} *)
@ -38,13 +38,13 @@ type 'm rule =
type 'm scope_decl = {
scope_decl_name : ScopeName.t;
scope_sig : (typ * Desugared.Ast.io) ScopeVarMap.t;
scope_sig : (typ * Desugared.Ast.io) ScopeVar.Map.t;
scope_decl_rules : 'm rule list;
scope_mark : 'm mark;
}
type 'm program = {
program_scopes : 'm scope_decl ScopeMap.t;
program_scopes : 'm scope_decl ScopeName.Map.t;
program_ctx : decl_ctx;
}

26
compiler/scopelang/dependency.ml
View File

@ -17,7 +17,7 @@
(** Graph representation of the dependencies between scopes in the Catala
program. Vertices are functions, x -> y if x is used in the definition of y. *)
open Utils
open Catala_utils
open Shared_ast
module SVertex = ScopeName
@ -41,12 +41,12 @@ module SSCC = Graph.Components.Make (SDependencies)
let rec expr_used_scopes e =
let recurse_subterms e =
Expr.shallow_fold
(fun e -> ScopeMap.union (fun _ x _ -> Some x) (expr_used_scopes e))
e ScopeMap.empty
(fun e -> ScopeName.Map.union (fun _ x _ -> Some x) (expr_used_scopes e))
e ScopeName.Map.empty
in
match e with
| (EScopeCall { scope; _ }, m) as e ->
ScopeMap.add scope (Expr.mark_pos m) (recurse_subterms e)
ScopeName.Map.add scope (Expr.mark_pos m) (recurse_subterms e)
| EAbs { binder; _ }, _ ->
let _, body = Bindlib.unmbind binder in
expr_used_scopes body
@ -58,28 +58,28 @@ let rule_used_scopes = function
walking through all exprs again *)
expr_used_scopes e
| Ast.Call (subscope, subindex, _) ->
ScopeMap.singleton subscope
ScopeName.Map.singleton subscope
(Marked.get_mark (SubScopeName.get_info subindex))
let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t =
let g = SDependencies.empty in
let g =
ScopeMap.fold
ScopeName.Map.fold
(fun v _ g -> SDependencies.add_vertex g v)
prgm.program_scopes g
in
ScopeMap.fold
ScopeName.Map.fold
(fun scope_name scope g ->
List.fold_left
(fun g rule ->
let used_scopes = rule_used_scopes rule in
if ScopeMap.mem scope_name used_scopes then
if ScopeName.Map.mem scope_name used_scopes then
Errors.raise_spanned_error
(Marked.get_mark (ScopeName.get_info scope.Ast.scope_decl_name))
"The scope %a is calling into itself as a subscope, which is \
forbidden since Catala does not provide recursion"
ScopeName.format_t scope.Ast.scope_decl_name;
ScopeMap.fold
ScopeName.Map.fold
(fun used_scope pos g ->
let edge = SDependencies.E.create used_scope pos scope_name in
SDependencies.add_edge_e g edge)
@ -190,9 +190,9 @@ let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t
=
let g = TDependencies.empty in
let g =
StructMap.fold
StructName.Map.fold
(fun s fields g ->
StructFieldMap.fold
StructField.Map.fold
(fun _ typ g ->
let def = TVertex.Struct s in
let g = TDependencies.add_vertex g def in
@ -214,9 +214,9 @@ let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t
structs g
in
let g =
EnumMap.fold
EnumName.Map.fold
(fun e cases g ->
EnumConstructorMap.fold
EnumConstructor.Map.fold
(fun _ typ g ->
let def = TVertex.Enum e in
let g = TDependencies.add_vertex g def in

2
compiler/scopelang/dependency.mli
View File

@ -17,7 +17,7 @@
(** Graph representation of the dependencies between scopes in the Catala
program. Vertices are functions, x -> y if x is used in the definition of y. *)
open Utils
open Catala_utils
open Shared_ast
(** {1 Scope dependencies} *)

2
compiler/scopelang/dune
View File

@ -1,7 +1,7 @@
(library
(name scopelang)
(public_name catala.scopelang)
(libraries utils ocamlgraph desugared)
(libraries catala_utils ocamlgraph desugared)
(flags
(:standard -short-paths)))

483
compiler/scopelang/from_desugared.ml
View File

@ -16,7 +16,7 @@
(** Translation from {!module: Desugared.Ast} to {!module: Scopelang.Ast} *)
open Utils
open Catala_utils
open Shared_ast
(** {1 Expression translation}*)
@ -26,14 +26,15 @@ type target_scope_vars =
| States of (StateName.t * ScopeVar.t) list
type ctx = {
scope_var_mapping : target_scope_vars ScopeVarMap.t;
decl_ctx : decl_ctx;
scope_var_mapping : target_scope_vars ScopeVar.Map.t;
var_mapping : (Desugared.Ast.expr, untyped Ast.expr Var.t) Var.Map.t;
}
let tag_with_log_entry
(e : untyped Ast.expr boxed)
(l : log_entry)
(markings : Utils.Uid.MarkedString.info list) : untyped Ast.expr boxed =
(markings : Uid.MarkedString.info list) : untyped Ast.expr boxed =
Expr.eapp
(Expr.eop (Unop (Log (l, markings))) (Marked.get_mark e))
[e] (Marked.get_mark e)
@ -46,7 +47,7 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) :
(* When referring to a subscope variable in an expression, we are referring
to the output, hence we take the last state. *)
let new_s_var =
match ScopeVarMap.find (Marked.unmark s_var) ctx.scope_var_mapping with
match ScopeVar.Map.find (Marked.unmark s_var) ctx.scope_var_mapping with
| WholeVar new_s_var -> Marked.same_mark_as new_s_var s_var
| States states ->
Marked.same_mark_as (snd (List.hd (List.rev states))) s_var
@ -56,7 +57,7 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) :
Expr.elocation
(ScopelangScopeVar
(match
ScopeVarMap.find (Marked.unmark s_var) ctx.scope_var_mapping
ScopeVar.Map.find (Marked.unmark s_var) ctx.scope_var_mapping
with
| WholeVar new_s_var -> Marked.same_mark_as new_s_var s_var
| States _ -> failwith "should not happen"))
@ -65,27 +66,44 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) :
Expr.elocation
(ScopelangScopeVar
(match
ScopeVarMap.find (Marked.unmark s_var) ctx.scope_var_mapping
ScopeVar.Map.find (Marked.unmark s_var) ctx.scope_var_mapping
with
| WholeVar _ -> failwith "should not happen"
| States states -> Marked.same_mark_as (List.assoc state states) s_var))
m
| EVar v -> Expr.evar (Var.Map.find v ctx.var_mapping) m
| EStruct { name; fields } ->
Expr.estruct name (StructFieldMap.map (translate_expr ctx) fields) m
| EStructAccess { e; field; name } ->
Expr.estructaccess (translate_expr ctx e) field name m
Expr.estruct name (StructField.Map.map (translate_expr ctx) fields) m
| EDStructAccess { name_opt = None; _ } ->
(* Note: this could only happen if disambiguation was disabled. If we want
to support it, we should still allow this case when the field has only
one possible matching structure *)
Errors.raise_spanned_error (Expr.mark_pos m)
"Ambiguous structure field access"
| EDStructAccess { e; field; name_opt = Some name } ->
let e' = translate_expr ctx e in
let field =
try
StructName.Map.find name
(IdentName.Map.find field ctx.decl_ctx.ctx_struct_fields)
with Not_found ->
(* Should not happen after disambiguation *)
Errors.raise_spanned_error (Expr.mark_pos m)
"Field %s does not belong to structure %a" field StructName.format_t
name
in
Expr.estructaccess e' field name m
| EInj { e; cons; name } -> Expr.einj (translate_expr ctx e) cons name m
| EMatch { e; name; cases } ->
Expr.ematch (translate_expr ctx e) name
(EnumConstructorMap.map (translate_expr ctx) cases)
(EnumConstructor.Map.map (translate_expr ctx) cases)
m
| EScopeCall { scope; args } ->
Expr.escopecall scope
(ScopeVarMap.fold
(ScopeVar.Map.fold
(fun v e args' ->
let v' =
match ScopeVarMap.find v ctx.scope_var_mapping with
match ScopeVar.Map.find v ctx.scope_var_mapping with
| WholeVar v' -> v'
| States ((_, v') :: _) ->
(* When there are multiple states, the input is always the first
@ -93,8 +111,8 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) :
v'
| States [] -> assert false
in
ScopeVarMap.add v' (translate_expr ctx e) args')
args ScopeVarMap.empty)
ScopeVar.Map.add v' (translate_expr ctx e) args')
args ScopeVar.Map.empty)
m
| ELit
(( LBool _ | LEmptyError | LInt _ | LRat _ | LMoney _ | LUnit | LDate _
@ -112,7 +130,7 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) :
Expr.eabs (Expr.bind new_vars (translate_expr ctx body)) tys m
| EApp { f; args } ->
Expr.eapp (translate_expr ctx f) (List.map (translate_expr ctx) args) m
| EOp op -> Expr.eop op m
| EOp op -> Expr.eop (Expr.translate_op op) m
| EDefault { excepts; just; cons } ->
Expr.edefault
(List.map (translate_expr ctx) excepts)
@ -139,7 +157,7 @@ type rule_tree =
priorities declared between rules *)
let def_map_to_tree
(def_info : Desugared.Ast.ScopeDef.t)
(def : Desugared.Ast.rule RuleMap.t) : rule_tree list =
(def : Desugared.Ast.rule RuleName.Map.t) : rule_tree list =
let exc_graph = Desugared.Dependency.build_exceptions_graph def def_info in
Desugared.Dependency.check_for_exception_cycle exc_graph;
(* we start by the base cases: they are the vertices which have no
@ -153,12 +171,14 @@ let def_map_to_tree
else base_cases)
exc_graph []
in
let rec build_tree (base_cases : RuleSet.t) : rule_tree =
let rec build_tree (base_cases : RuleName.Set.t) : rule_tree =
let exceptions =
Desugared.Dependency.ExceptionsDependencies.pred exc_graph base_cases
in
let base_case_as_rule_list =
List.map (fun r -> RuleMap.find r def) (RuleSet.elements base_cases)
List.map
(fun r -> RuleName.Map.find r def)
(RuleName.Set.elements base_cases)
in
match exceptions with
| [] -> Leaf base_case_as_rule_list
@ -286,7 +306,7 @@ let rec rule_tree_to_expr
let translate_def
(ctx : ctx)
(def_info : Desugared.Ast.ScopeDef.t)
(def : Desugared.Ast.rule RuleMap.t)
(def : Desugared.Ast.rule RuleName.Map.t)
(typ : typ)
(io : Desugared.Ast.io)
~(is_cond : bool)
@ -298,9 +318,9 @@ let translate_def
let is_rule_func _ (r : Desugared.Ast.rule) : bool =
Option.is_some r.Desugared.Ast.rule_parameter
in
let all_rules_func = RuleMap.for_all is_rule_func def in
let all_rules_func = RuleName.Map.for_all is_rule_func def in
let all_rules_not_func =
RuleMap.for_all (fun n r -> not (is_rule_func n r)) def
RuleName.Map.for_all (fun n r -> not (is_rule_func n r)) def
in
let is_def_func_param_typ : typ option =
if is_def_func && all_rules_func then
@ -318,13 +338,13 @@ let translate_def
(fun (_, r) ->
( Some "This definition is a function:",
Expr.pos r.Desugared.Ast.rule_cons ))
(RuleMap.bindings (RuleMap.filter is_rule_func def))
(RuleName.Map.bindings (RuleName.Map.filter is_rule_func def))
@ List.map
(fun (_, r) ->
( Some "This definition is not a function:",
Expr.pos r.Desugared.Ast.rule_cons ))
(RuleMap.bindings
(RuleMap.filter (fun n r -> not (is_rule_func n r)) def))
(RuleName.Map.bindings
(RuleName.Map.filter (fun n r -> not (is_rule_func n r)) def))
in
Errors.raise_multispanned_error spans
"some definitions of the same variable are functions while others \
@ -353,7 +373,7 @@ let translate_def
else None
in
if
RuleMap.cardinal def = 0
RuleName.Map.cardinal def = 0
&& is_subscope_var
(* Here we have a special case for the empty definitions. Indeed, we could
use the code for the regular case below that would create a convoluted
@ -411,6 +431,158 @@ let translate_def
is_def_func_param_typ;
] ))
let translate_rule ctx (scope : Desugared.Ast.scope) = function
| Desugared.Dependency.Vertex.Var (var, state) -> (
let scope_def =
Desugared.Ast.ScopeDefMap.find
(Desugared.Ast.ScopeDef.Var (var, state))
scope.scope_defs
in
let var_def = scope_def.scope_def_rules in
let var_typ = scope_def.scope_def_typ in
let is_cond = scope_def.scope_def_is_condition in
match Marked.unmark scope_def.Desugared.Ast.scope_def_io.io_input with
| OnlyInput when not (RuleName.Map.is_empty var_def) ->
(* If the variable is tagged as input, then it shall not be redefined. *)
Errors.raise_multispanned_error
((Some "Incriminated variable:", Marked.get_mark (ScopeVar.get_info var))
:: List.map
(fun (rule, _) ->
( Some "Incriminated variable definition:",
Marked.get_mark (RuleName.get_info rule) ))
(RuleName.Map.bindings var_def))
"It is impossible to give a definition to a scope variable tagged as \
input."
| OnlyInput -> []
(* we do not provide any definition for an input-only variable *)
| _ ->
let expr_def =
translate_def ctx
(Desugared.Ast.ScopeDef.Var (var, state))
var_def var_typ scope_def.Desugared.Ast.scope_def_io ~is_cond
~is_subscope_var:false
in
let scope_var =
match ScopeVar.Map.find var ctx.scope_var_mapping, state with
| WholeVar v, None -> v
| States states, Some state -> List.assoc state states
| _ -> failwith "should not happen"
in
[
Ast.Definition
( ( ScopelangScopeVar
(scope_var, Marked.get_mark (ScopeVar.get_info scope_var)),
Marked.get_mark (ScopeVar.get_info scope_var) ),
var_typ,
scope_def.Desugared.Ast.scope_def_io,
Expr.unbox expr_def );
])
| Desugared.Dependency.Vertex.SubScope sub_scope_index ->
(* Before calling the sub_scope, we need to include all the re-definitions
of subscope parameters*)
let sub_scope =
SubScopeName.Map.find sub_scope_index scope.scope_sub_scopes
in
let sub_scope_vars_redefs_candidates =
Desugared.Ast.ScopeDefMap.filter
(fun def_key scope_def ->
match def_key with
| Desugared.Ast.ScopeDef.Var _ -> false
| Desugared.Ast.ScopeDef.SubScopeVar (sub_scope_index', _, _) ->
sub_scope_index = sub_scope_index'
(* We exclude subscope variables that have 0 re-definitions and are
not visible in the input of the subscope *)
&& not
((match
Marked.unmark scope_def.Desugared.Ast.scope_def_io.io_input
with
| Desugared.Ast.NoInput -> true
| _ -> false)
&& RuleName.Map.is_empty scope_def.scope_def_rules))
scope.scope_defs
in
let sub_scope_vars_redefs =
Desugared.Ast.ScopeDefMap.mapi
(fun def_key scope_def ->
let def = scope_def.Desugared.Ast.scope_def_rules in
let def_typ = scope_def.scope_def_typ in
let is_cond = scope_def.scope_def_is_condition in
match def_key with
| Desugared.Ast.ScopeDef.Var _ -> assert false (* should not happen *)
| Desugared.Ast.ScopeDef.SubScopeVar (sscope, sub_scope_var, pos) ->
(* This definition redefines a variable of the correct subscope. But
we have to check that this redefinition is allowed with respect
to the io parameters of that subscope variable. *)
(match
Marked.unmark scope_def.Desugared.Ast.scope_def_io.io_input
with
| Desugared.Ast.NoInput ->
Errors.raise_multispanned_error
(( Some "Incriminated subscope:",
Marked.get_mark (SubScopeName.get_info sscope) )
:: ( Some "Incriminated variable:",
Marked.get_mark (ScopeVar.get_info sub_scope_var) )
:: List.map
(fun (rule, _) ->
( Some "Incriminated subscope variable definition:",
Marked.get_mark (RuleName.get_info rule) ))
(RuleName.Map.bindings def))
"It is impossible to give a definition to a subscope variable \
not tagged as input or context."
| OnlyInput when RuleName.Map.is_empty def && not is_cond ->
(* If the subscope variable is tagged as input, then it shall be
defined. *)
Errors.raise_multispanned_error
[
( Some "Incriminated subscope:",
Marked.get_mark (SubScopeName.get_info sscope) );
Some "Incriminated variable:", pos;
]
"This subscope variable is a mandatory input but no definition \
was provided."
| _ -> ());
(* Now that all is good, we can proceed with translating this
redefinition to a proper Scopelang term. *)
let expr_def =
translate_def ctx def_key def def_typ
scope_def.Desugared.Ast.scope_def_io ~is_cond
~is_subscope_var:true
in
let subscop_real_name =
SubScopeName.Map.find sub_scope_index scope.scope_sub_scopes
in
let var_pos = Desugared.Ast.ScopeDef.get_position def_key in
Ast.Definition
( ( SubScopeVar
( subscop_real_name,
(sub_scope_index, var_pos),
match
ScopeVar.Map.find sub_scope_var ctx.scope_var_mapping
with
| WholeVar v -> v, var_pos
| States states ->
(* When defining a sub-scope variable, we always define
its first state in the sub-scope. *)
snd (List.hd states), var_pos ),
var_pos ),
def_typ,
scope_def.Desugared.Ast.scope_def_io,
Expr.unbox expr_def ))
sub_scope_vars_redefs_candidates
in
let sub_scope_vars_redefs =
List.map snd (Desugared.Ast.ScopeDefMap.bindings sub_scope_vars_redefs)
in
sub_scope_vars_redefs
@ [
Ast.Call
( sub_scope,
sub_scope_index,
Untyped
{ pos = Marked.get_mark (SubScopeName.get_info sub_scope_index) }
);
]
(** Translates a scope *)
let translate_scope (ctx : ctx) (scope : Desugared.Ast.scope) :
untyped Ast.scope_decl =
@ -422,183 +594,7 @@ let translate_scope (ctx : ctx) (scope : Desugared.Ast.scope) :
Desugared.Dependency.correct_computation_ordering scope_dependencies
in
let scope_decl_rules =
List.flatten
(List.map
(fun vertex ->
match vertex with
| Desugared.Dependency.Vertex.Var (var, state) -> (
let scope_def =
Desugared.Ast.ScopeDefMap.find
(Desugared.Ast.ScopeDef.Var (var, state))
scope.scope_defs
in
let var_def = scope_def.scope_def_rules in
let var_typ = scope_def.scope_def_typ in
let is_cond = scope_def.scope_def_is_condition in
match
Marked.unmark scope_def.Desugared.Ast.scope_def_io.io_input
with
| OnlyInput when not (RuleMap.is_empty var_def) ->
(* If the variable is tagged as input, then it shall not be
redefined. *)
Errors.raise_multispanned_error
(( Some "Incriminated variable:",
Marked.get_mark (ScopeVar.get_info var) )
:: List.map
(fun (rule, _) ->
( Some "Incriminated variable definition:",
Marked.get_mark (RuleName.get_info rule) ))
(RuleMap.bindings var_def))
"It is impossible to give a definition to a scope variable \
tagged as input."
| OnlyInput ->
[]
(* we do not provide any definition for an input-only variable *)
| _ ->
let expr_def =
translate_def ctx
(Desugared.Ast.ScopeDef.Var (var, state))
var_def var_typ scope_def.Desugared.Ast.scope_def_io ~is_cond
~is_subscope_var:false
in
let scope_var =
match ScopeVarMap.find var ctx.scope_var_mapping, state with
| WholeVar v, None -> v
| States states, Some state -> List.assoc state states
| _ -> failwith "should not happen"
in
[
Ast.Definition
( ( ScopelangScopeVar
( scope_var,
Marked.get_mark (ScopeVar.get_info scope_var) ),
Marked.get_mark (ScopeVar.get_info scope_var) ),
var_typ,
scope_def.Desugared.Ast.scope_def_io,
Expr.unbox expr_def );
])
| Desugared.Dependency.Vertex.SubScope sub_scope_index ->
(* Before calling the sub_scope, we need to include all the
re-definitions of subscope parameters*)
let sub_scope =
SubScopeMap.find sub_scope_index scope.scope_sub_scopes
in
let sub_scope_vars_redefs_candidates =
Desugared.Ast.ScopeDefMap.filter
(fun def_key scope_def ->
match def_key with
| Desugared.Ast.ScopeDef.Var _ -> false
| Desugared.Ast.ScopeDef.SubScopeVar (sub_scope_index', _, _)
->
sub_scope_index = sub_scope_index'
(* We exclude subscope variables that have 0 re-definitions
and are not visible in the input of the subscope *)
&& not
((match
Marked.unmark
scope_def.Desugared.Ast.scope_def_io.io_input
with
| Desugared.Ast.NoInput -> true
| _ -> false)
&& RuleMap.is_empty scope_def.scope_def_rules))
scope.scope_defs
in
let sub_scope_vars_redefs =
Desugared.Ast.ScopeDefMap.mapi
(fun def_key scope_def ->
let def = scope_def.Desugared.Ast.scope_def_rules in
let def_typ = scope_def.scope_def_typ in
let is_cond = scope_def.scope_def_is_condition in
match def_key with
| Desugared.Ast.ScopeDef.Var _ ->
assert false (* should not happen *)
| Desugared.Ast.ScopeDef.SubScopeVar
(sscope, sub_scope_var, pos) ->
(* This definition redefines a variable of the correct
subscope. But we have to check that this redefinition is
allowed with respect to the io parameters of that
subscope variable. *)
(match
Marked.unmark
scope_def.Desugared.Ast.scope_def_io.io_input
with
| Desugared.Ast.NoInput ->
Errors.raise_multispanned_error
(( Some "Incriminated subscope:",
Marked.get_mark (SubScopeName.get_info sscope) )
:: ( Some "Incriminated variable:",
Marked.get_mark (ScopeVar.get_info sub_scope_var)
)
:: List.map
(fun (rule, _) ->
( Some
"Incriminated subscope variable definition:",
Marked.get_mark (RuleName.get_info rule) ))
(RuleMap.bindings def))
"It is impossible to give a definition to a subscope \
variable not tagged as input or context."
| OnlyInput when RuleMap.is_empty def && not is_cond ->
(* If the subscope variable is tagged as input, then it
shall be defined. *)
Errors.raise_multispanned_error
[
( Some "Incriminated subscope:",
Marked.get_mark (SubScopeName.get_info sscope) );
Some "Incriminated variable:", pos;
]
"This subscope variable is a mandatory input but no \
definition was provided."
| _ -> ());
(* Now that all is good, we can proceed with translating
this redefinition to a proper Scopelang term. *)
let expr_def =
translate_def ctx def_key def def_typ
scope_def.Desugared.Ast.scope_def_io ~is_cond
~is_subscope_var:true
in
let subscop_real_name =
SubScopeMap.find sub_scope_index scope.scope_sub_scopes
in
let var_pos =
Desugared.Ast.ScopeDef.get_position def_key
in
Ast.Definition
( ( SubScopeVar
( subscop_real_name,
(sub_scope_index, var_pos),
match
ScopeVarMap.find sub_scope_var
ctx.scope_var_mapping
with
| WholeVar v -> v, var_pos
| States states ->
(* When defining a sub-scope variable, we
always define its first state in the
sub-scope. *)
snd (List.hd states), var_pos ),
var_pos ),
def_typ,
scope_def.Desugared.Ast.scope_def_io,
Expr.unbox expr_def ))
sub_scope_vars_redefs_candidates
in
let sub_scope_vars_redefs =
List.map snd
(Desugared.Ast.ScopeDefMap.bindings sub_scope_vars_redefs)
in
sub_scope_vars_redefs
@ [
Ast.Call
( sub_scope,
sub_scope_index,
Untyped
{
pos =
Marked.get_mark
(SubScopeName.get_info sub_scope_index);
} );
])
scope_ordering)
List.flatten (List.map (translate_rule ctx scope) scope_ordering)
in
(* Then, after having computed all the scopes variables, we add the
assertions. TODO: the assertions should be interleaved with the
@ -612,7 +608,7 @@ let translate_scope (ctx : ctx) (scope : Desugared.Ast.scope) :
scope.Desugared.Ast.scope_assertions
in
let scope_sig =
ScopeVarMap.fold
ScopeVar.Map.fold
(fun var (states : Desugared.Ast.var_or_states) acc ->
match states with
| WholeVar ->
@ -622,8 +618,8 @@ let translate_scope (ctx : ctx) (scope : Desugared.Ast.scope) :
scope.scope_defs
in
let typ = scope_def.scope_def_typ in
ScopeVarMap.add
(match ScopeVarMap.find var ctx.scope_var_mapping with
ScopeVar.Map.add
(match ScopeVar.Map.find var ctx.scope_var_mapping with
| WholeVar v -> v
| States _ -> failwith "should not happen")
(typ, scope_def.scope_def_io)
@ -639,14 +635,14 @@ let translate_scope (ctx : ctx) (scope : Desugared.Ast.scope) :
(Desugared.Ast.ScopeDef.Var (var, Some state))
scope.scope_defs
in
ScopeVarMap.add
(match ScopeVarMap.find var ctx.scope_var_mapping with
ScopeVar.Map.add
(match ScopeVar.Map.find var ctx.scope_var_mapping with
| WholeVar _ -> failwith "should not happen"
| States states' -> List.assoc state states')
(scope_def.scope_def_typ, scope_def.scope_def_io)
acc)
acc states)
scope.scope_vars ScopeVarMap.empty
scope.scope_vars ScopeVar.Map.empty
in
let pos = Marked.get_mark (ScopeName.get_info scope.scope_uid) in
{
@ -665,61 +661,56 @@ let translate_program (pgrm : Desugared.Ast.program) : untyped Ast.program =
let ctx =
(* 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 *)
ScopeMap.fold
ScopeName.Map.fold
(fun _scope scope_decl ctx ->
ScopeVarMap.fold
ScopeVar.Map.fold
(fun scope_var (states : Desugared.Ast.var_or_states) ctx ->
match states with
| Desugared.Ast.WholeVar ->
{
ctx with
scope_var_mapping =
ScopeVarMap.add scope_var
(WholeVar (ScopeVar.fresh (ScopeVar.get_info scope_var)))
ctx.scope_var_mapping;
}
| States states ->
{
ctx with
scope_var_mapping =
ScopeVarMap.add scope_var
(States
(List.map
(fun state ->
( state,
ScopeVar.fresh
(let state_name, state_pos =
StateName.get_info state
in
( Marked.unmark (ScopeVar.get_info scope_var)
^ "_"
^ state_name,
state_pos )) ))
states))
ctx.scope_var_mapping;
})
let var_name, var_pos = ScopeVar.get_info scope_var in
let new_var =
match states with
| Desugared.Ast.WholeVar ->
WholeVar (ScopeVar.fresh (var_name, var_pos))
| States states ->
let var_prefix = var_name ^ "_" in
let state_var state =
ScopeVar.fresh
(Marked.map_under_mark (( ^ ) var_prefix)
(StateName.get_info state))
in
States (List.map (fun state -> state, state_var state) states)
in
{
ctx with
scope_var_mapping =
ScopeVar.Map.add scope_var new_var ctx.scope_var_mapping;
})
scope_decl.Desugared.Ast.scope_vars ctx)
pgrm.Desugared.Ast.program_scopes
{ scope_var_mapping = ScopeVarMap.empty; var_mapping = Var.Map.empty }
{
scope_var_mapping = ScopeVar.Map.empty;
var_mapping = Var.Map.empty;
decl_ctx = pgrm.program_ctx;
}
in
let ctx_scopes =
ScopeMap.map
ScopeName.Map.map
(fun out_str ->
let out_struct_fields =
ScopeVarMap.fold
ScopeVar.Map.fold
(fun var fld out_map ->
let var' =
match ScopeVarMap.find var ctx.scope_var_mapping with
match ScopeVar.Map.find var ctx.scope_var_mapping with
| WholeVar v -> v
| States l -> snd (List.hd (List.rev l))
in
ScopeVarMap.add var' fld out_map)
out_str.out_struct_fields ScopeVarMap.empty
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
{
Ast.program_scopes = ScopeMap.map (translate_scope ctx) pgrm.program_scopes;
Ast.program_scopes =
ScopeName.Map.map (translate_scope ctx) pgrm.program_scopes;
program_ctx = { pgrm.program_ctx with ctx_scopes };
}

22
compiler/scopelang/print.ml
View File

@ -14,7 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
open Shared_ast
open Ast
@ -22,22 +22,22 @@ let struc
ctx
(fmt : Format.formatter)
(name : StructName.t)
(fields : typ StructFieldMap.t) : unit =
(fields : typ StructField.Map.t) : unit =
Format.fprintf fmt "%a %a %a %a@\n@[<hov 2> %a@]@\n%a" Print.keyword "struct"
StructName.format_t name Print.punctuation "=" Print.punctuation "{"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (field_name, typ) ->
Format.fprintf fmt "%a%a %a" StructFieldName.format_t field_name
Format.fprintf fmt "%a%a %a" StructField.format_t field_name
Print.punctuation ":" (Print.typ ctx) typ))
(StructFieldMap.bindings fields)
(StructField.Map.bindings fields)
Print.punctuation "}"
let enum
ctx
(fmt : Format.formatter)
(name : EnumName.t)
(cases : typ EnumConstructorMap.t) : unit =
(cases : typ EnumConstructor.Map.t) : unit =
Format.fprintf fmt "%a %a %a @\n@[<hov 2> %a@]" Print.keyword "enum"
EnumName.format_t name Print.punctuation "="
(Format.pp_print_list
@ -46,7 +46,7 @@ let enum
Format.fprintf fmt "%a %a%a %a" Print.punctuation "|"
EnumConstructor.format_t field_name Print.punctuation ":"
(Print.typ ctx) typ))
(EnumConstructorMap.bindings cases)
(EnumConstructor.Map.bindings cases)
let scope ?(debug = false) ctx fmt (name, decl) =
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@ %a@]@\n@[<v 2> %a@]"
@ -65,7 +65,7 @@ let scope ?(debug = false) ctx fmt (name, decl) =
"output"
else fun fmt () -> Format.fprintf fmt "@<0>")
() Print.punctuation ")"))
(ScopeVarMap.bindings decl.scope_sig)
(ScopeVar.Map.bindings decl.scope_sig)
Print.punctuation "="
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " Print.punctuation ";")
@ -81,7 +81,7 @@ let scope ?(debug = false) ctx fmt (name, decl) =
| ScopelangScopeVar v -> (
match
Marked.unmark
(snd (ScopeVarMap.find (Marked.unmark v) decl.scope_sig))
(snd (ScopeVar.Map.find (Marked.unmark v) decl.scope_sig))
.io_input
with
| Reentrant ->
@ -106,16 +106,16 @@ let program ?(debug : bool = false) (fmt : Format.formatter) (p : 'm program) :
Format.pp_print_cut fmt ()
in
Format.pp_open_vbox fmt 0;
StructMap.iter
StructName.Map.iter
(fun n s ->
struc ctx fmt n s;
pp_sep fmt ())
ctx.ctx_structs;
EnumMap.iter
EnumName.Map.iter
(fun n e ->
enum ctx fmt n e;
pp_sep fmt ())
ctx.ctx_enums;
Format.pp_print_list ~pp_sep (scope ~debug ctx) fmt
(ScopeMap.bindings p.program_scopes);
(ScopeName.Map.bindings p.program_scopes);
Format.pp_close_box fmt ()

165
compiler/shared_ast/definitions.ml
View File

@ -20,73 +20,47 @@
(* Doesn't define values, so OK to have without an mli *)
open Utils
open Catala_utils
module Runtime = Runtime_ocaml.Runtime
module ScopeName : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
module ScopeSet : Set.S with type elt = ScopeName.t = Set.Make (ScopeName)
module ScopeMap : Map.S with type key = ScopeName.t = Map.Make (ScopeName)
module StructName : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
module StructFieldName : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
module StructMap : Map.S with type key = StructName.t = Map.Make (StructName)
module EnumName : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
module EnumConstructor : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
module EnumMap : Map.S with type key = EnumName.t = Map.Make (EnumName)
module ScopeName = Uid.Gen ()
module StructName = Uid.Gen ()
module StructField = Uid.Gen ()
module EnumName = Uid.Gen ()
module EnumConstructor = Uid.Gen ()
(** Only used by surface *)
module RuleName : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
module RuleName = Uid.Gen ()
module LabelName = Uid.Gen ()
module RuleMap : Map.S with type key = RuleName.t = Map.Make (RuleName)
module RuleSet : Set.S with type elt = RuleName.t = Set.Make (RuleName)
(** Used for unresolved structs/maps in desugared *)
module LabelName : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
module LabelMap : Map.S with type key = LabelName.t = Map.Make (LabelName)
module LabelSet : Set.S with type elt = LabelName.t = Set.Make (LabelName)
module IdentName = String
(** Only used by desugared/scopelang *)
module ScopeVar : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
module ScopeVarSet : Set.S with type elt = ScopeVar.t = Set.Make (ScopeVar)
module ScopeVarMap : Map.S with type key = ScopeVar.t = Map.Make (ScopeVar)
module SubScopeName : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
module SubScopeNameSet : Set.S with type elt = SubScopeName.t =
Set.Make (SubScopeName)
module SubScopeMap : Map.S with type key = SubScopeName.t =
Map.Make (SubScopeName)
module StructFieldMap : Map.S with type key = StructFieldName.t =
Map.Make (StructFieldName)
module EnumConstructorMap : Map.S with type key = EnumConstructor.t =
Map.Make (EnumConstructor)
module StateName : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
module ScopeVar = Uid.Gen ()
module SubScopeName = Uid.Gen ()
module StateName = Uid.Gen ()
(** {1 Abstract syntax tree} *)
(** Define a common base type for the expressions in most passes of the compiler *)
type desugared = [ `Desugared ]
(** {2 Phantom types used to select relevant cases on the generic AST}
we instantiate them with a polymorphic variant to take advantage of
sub-typing. The values aren't actually used. *)
type scopelang = [ `Scopelang ]
type dcalc = [ `Dcalc ]
type lcalc = [ `Lcalc ]
type 'a any = [< desugared | scopelang | dcalc | lcalc ] as 'a
(** ['a any] is 'a, but adds the constraint that it should be restricted to
valid AST kinds *)
(** {2 Types} *)
type typ_lit = TBool | TUnit | TInt | TRat | TMoney | TDate | TDuration
@ -108,27 +82,28 @@ and naked_typ =
type date = Runtime.date
type duration = Runtime.duration
type op_kind =
| KInt
| KRat
| KMoney
| KDate
| KDuration (** All ops don't have a KDate and KDuration. *)
type 'a op_kind =
(* | Kpoly: desugared op_kind -- Coming soon ! *)
| KInt : 'a any op_kind
| KRat : 'a any op_kind
| KMoney : 'a any op_kind
| KDate : 'a any op_kind
| KDuration : 'a any op_kind (** All ops don't have a KDate and KDuration. *)
type ternop = Fold
type binop =
type 'a binop =
| And
| Or
| Xor
| Add of op_kind
| Sub of op_kind
| Mult of op_kind
| Div of op_kind
| Lt of op_kind
| Lte of op_kind
| Gt of op_kind
| Gte of op_kind
| Add of 'a op_kind
| Sub of 'a op_kind
| Mult of 'a op_kind
| Div of 'a op_kind
| Lt of 'a op_kind
| Lte of 'a op_kind
| Gt of 'a op_kind
| Gte of 'a op_kind
| Eq
| Neq
| Map
@ -143,9 +118,9 @@ type log_entry =
| EndCall
| PosRecordIfTrueBool
type unop =
type 'a unop =
| Not
| Minus of op_kind
| Minus of 'a op_kind
| Log of log_entry * Uid.MarkedString.info list
| Length
| IntToRat
@ -159,19 +134,13 @@ type unop =
| RoundMoney
| RoundDecimal
type operator = Ternop of ternop | Binop of binop | Unop of unop
type 'a operator = Ternop of ternop | Binop of 'a binop | Unop of 'a unop
type except = ConflictError | EmptyError | NoValueProvided | Crash
(** {2 Generic expressions} *)
(** Define a common base type for the expressions in most passes of the compiler *)
type desugared = [ `Desugared ]
type scopelang = [ `Scopelang ]
type dcalc = [ `Dcalc ]
type lcalc = [ `Lcalc ]
type 'a any = [< desugared | scopelang | dcalc | lcalc ] as 'a
(** Literals are the same throughout compilation except for the [LEmptyError]
case which is eliminated midway through. *)
type 'a glit =
@ -216,7 +185,7 @@ and ('a, 't) naked_gexpr =
args : ('a, 't) gexpr list;
}
-> ('a any, 't) naked_gexpr
| EOp : operator -> ('a any, 't) naked_gexpr
| EOp : 'a operator -> ('a any, 't) naked_gexpr
| EArray : ('a, 't) gexpr list -> ('a any, 't) naked_gexpr
| EVar : ('a, 't) naked_gexpr Bindlib.var -> ('a any, 't) naked_gexpr
| EAbs : {
@ -232,13 +201,7 @@ and ('a, 't) naked_gexpr =
-> ('a any, 't) naked_gexpr
| EStruct : {
name : StructName.t;
fields : ('a, 't) gexpr StructFieldMap.t;
}
-> ('a any, 't) naked_gexpr
| EStructAccess : {
name : StructName.t;
e : ('a, 't) gexpr;
field : StructFieldName.t;
fields : ('a, 't) gexpr StructField.Map.t;
}
-> ('a any, 't) naked_gexpr
| EInj : {
@ -250,7 +213,7 @@ and ('a, 't) naked_gexpr =
| EMatch : {
name : EnumName.t;
e : ('a, 't) gexpr;
cases : ('a, 't) gexpr EnumConstructorMap.t;
cases : ('a, 't) gexpr EnumConstructor.Map.t;
}
-> ('a any, 't) naked_gexpr
(* Early stages *)
@ -259,9 +222,23 @@ and ('a, 't) naked_gexpr =
-> (([< desugared | scopelang ] as 'a), 't) naked_gexpr
| EScopeCall : {
scope : ScopeName.t;
args : ('a, 't) gexpr ScopeVarMap.t;
args : ('a, 't) gexpr ScopeVar.Map.t;
}
-> (([< desugared | scopelang ] as 'a), 't) naked_gexpr
(* [desugared] has ambiguous struct fields *)
| EDStructAccess : {
name_opt : StructName.t option;
e : ('a, 't) gexpr;
field : IdentName.t;
}
-> ((desugared as 'a), 't) naked_gexpr
(* Resolved struct/enums, after [desugared] *)
| EStructAccess : {
name : StructName.t;
e : ('a, 't) gexpr;
field : StructField.t;
}
-> (([< scopelang | dcalc | lcalc ] as 'a), 't) naked_gexpr
(* Lambda-like *)
| EAssert : ('a, 't) gexpr -> (([< dcalc | lcalc ] as 'a), 't) naked_gexpr
(* Default terms *)
@ -386,18 +363,20 @@ and 'e scopes =
| ScopeDef of 'e scope_def
constraint 'e = (_ any, _ mark) gexpr
type struct_ctx = typ StructFieldMap.t StructMap.t
type enum_ctx = typ EnumConstructorMap.t EnumMap.t
type struct_ctx = typ StructField.Map.t StructName.Map.t
type enum_ctx = typ EnumConstructor.Map.t EnumName.Map.t
type scope_out_struct = {
out_struct_name : StructName.t;
out_struct_fields : StructFieldName.t ScopeVarMap.t;
out_struct_fields : StructField.t ScopeVar.Map.t;
}
type decl_ctx = {
ctx_enums : enum_ctx;
ctx_structs : struct_ctx;
ctx_scopes : scope_out_struct ScopeMap.t;
ctx_struct_fields : StructField.t StructName.Map.t IdentName.Map.t;
(** needed for disambiguation (desugared -> scope) *)
ctx_scopes : scope_out_struct ScopeName.Map.t;
}
type 'e program = { decl_ctx : decl_ctx; scopes : 'e scopes }

2
compiler/shared_ast/dune
View File

@ -3,4 +3,4 @@
(public_name catala.shared_ast)
(flags
(:standard -short-paths))
(libraries bindlib unionFind utils catala.runtime_ocaml))
(libraries bindlib unionFind catala_utils catala.runtime_ocaml))

154
compiler/shared_ast/expr.ml
View File

@ -15,7 +15,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
open Definitions
(** Functions handling the types of [shared_ast] *)
@ -57,15 +57,15 @@ module Box = struct
fun em ->
B.box_apply (fun e -> Marked.mark (Marked.get_mark em) e) (Marked.unmark em)
module LiftStruct = Bindlib.Lift (StructFieldMap)
module LiftStruct = Bindlib.Lift (StructField.Map)
let lift_struct = LiftStruct.lift_box
module LiftEnum = Bindlib.Lift (EnumConstructorMap)
module LiftEnum = Bindlib.Lift (EnumConstructor.Map)
let lift_enum = LiftEnum.lift_box
module LiftScopeVars = Bindlib.Lift (ScopeVarMap)
module LiftScopeVars = Bindlib.Lift (ScopeVar.Map)
let lift_scope_vars = LiftScopeVars.lift_box
end
@ -108,11 +108,14 @@ let ecatch body exn handler =
let elocation loc = Box.app0 @@ ELocation loc
let estruct name (fields : ('a, 't) boxed_gexpr StructFieldMap.t) mark =
let estruct name (fields : ('a, 't) boxed_gexpr StructField.Map.t) mark =
Marked.mark mark
@@ Bindlib.box_apply
(fun fields -> EStruct { name; fields })
(Box.lift_struct (StructFieldMap.map Box.lift fields))
(Box.lift_struct (StructField.Map.map Box.lift fields))
let edstructaccess e field name_opt =
Box.app1 e @@ fun e -> EDStructAccess { name_opt; e; field }
let estructaccess e field name =
Box.app1 e @@ fun e -> EStructAccess { name; e; field }
@ -124,13 +127,13 @@ let ematch e name cases mark =
@@ Bindlib.box_apply2
(fun e cases -> EMatch { name; e; cases })
(Box.lift e)
(Box.lift_enum (EnumConstructorMap.map Box.lift cases))
(Box.lift_enum (EnumConstructor.Map.map Box.lift cases))
let escopecall scope args mark =
Marked.mark mark
@@ Bindlib.box_apply
(fun args -> EScopeCall { scope; args })
(Box.lift_scope_vars (ScopeVarMap.map Box.lift args))
(Box.lift_scope_vars (ScopeVar.Map.map Box.lift args))
(* - Manipulation of marks - *)
@ -230,14 +233,16 @@ let map
| ERaise exn -> eraise exn m
| ELocation loc -> elocation loc m
| EStruct { name; fields } ->
let fields = StructFieldMap.map f fields in
let fields = StructField.Map.map f fields in
estruct name fields m
| EDStructAccess { e; field; name_opt } ->
edstructaccess (f e) field name_opt m
| EStructAccess { e; field; name } -> estructaccess (f e) field name m
| EMatch { e; name; cases } ->
let cases = EnumConstructorMap.map f cases in
let cases = EnumConstructor.Map.map f cases in
ematch (f e) name cases m
| EScopeCall { scope; args } ->
let fields = ScopeVarMap.map f args in
let fields = ScopeVar.Map.map f args in
escopecall scope fields m
let rec map_top_down ~f e = map ~f:(map_top_down ~f) (f e)
@ -266,11 +271,12 @@ let shallow_fold
| EDefault { excepts; just; cons } -> acc |> lfold excepts |> f just |> f cons
| EErrorOnEmpty e -> acc |> f e
| ECatch { body; handler; _ } -> acc |> f body |> f handler
| EStruct { fields; _ } -> acc |> StructFieldMap.fold (fun _ -> f) fields
| EStruct { fields; _ } -> acc |> StructField.Map.fold (fun _ -> f) fields
| EDStructAccess { e; _ } -> acc |> f e
| EStructAccess { e; _ } -> acc |> f e
| EMatch { e; cases; _ } ->
acc |> f e |> EnumConstructorMap.fold (fun _ -> f) cases
| EScopeCall { args; _ } -> acc |> ScopeVarMap.fold (fun _ -> f) args
acc |> f e |> EnumConstructor.Map.fold (fun _ -> f) cases
| EScopeCall { args; _ } -> acc |> ScopeVar.Map.fold (fun _ -> f) args
(* Like [map], but also allows to gather a result bottom-up. *)
let map_gather
@ -339,35 +345,38 @@ let map_gather
| ELocation loc -> acc, elocation loc m
| EStruct { name; fields } ->
let acc, fields =
StructFieldMap.fold
StructField.Map.fold
(fun cons e (acc, fields) ->
let acc1, e = f e in
join acc acc1, StructFieldMap.add cons e fields)
join acc acc1, StructField.Map.add cons e fields)
fields
(acc, StructFieldMap.empty)
(acc, StructField.Map.empty)
in
acc, estruct name fields m
| EDStructAccess { e; field; name_opt } ->
let acc, e = f e in
acc, edstructaccess e field name_opt m
| EStructAccess { e; field; name } ->
let acc, e = f e in
acc, estructaccess e field name m
| EMatch { e; name; cases } ->
let acc, e = f e in
let acc, cases =
EnumConstructorMap.fold
EnumConstructor.Map.fold
(fun cons e (acc, cases) ->
let acc1, e = f e in
join acc acc1, EnumConstructorMap.add cons e cases)
join acc acc1, EnumConstructor.Map.add cons e cases)
cases
(acc, EnumConstructorMap.empty)
(acc, EnumConstructor.Map.empty)
in
acc, ematch e name cases m
| EScopeCall { scope; args } ->
let acc, args =
ScopeVarMap.fold
ScopeVar.Map.fold
(fun var e (acc, args) ->
let acc1, e = f e in
join acc acc1, ScopeVarMap.add var e args)
args (acc, ScopeVarMap.empty)
join acc acc1, ScopeVar.Map.add var e args)
args (acc, ScopeVar.Map.empty)
in
acc, escopecall scope args m
@ -688,10 +697,13 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool =
equal_location (Marked.mark Pos.no_pos l1) (Marked.mark Pos.no_pos l2)
| ( EStruct { name = s1; fields = fields1 },
EStruct { name = s2; fields = fields2 } ) ->
StructName.equal s1 s2 && StructFieldMap.equal equal fields1 fields2
StructName.equal s1 s2 && StructField.Map.equal equal fields1 fields2
| ( EDStructAccess { e = e1; field = f1; name_opt = s1 },
EDStructAccess { e = e2; field = f2; name_opt = s2 } ) ->
Option.equal StructName.equal s1 s2 && IdentName.equal f1 f2 && equal e1 e2
| ( EStructAccess { e = e1; field = f1; name = s1 },
EStructAccess { e = e2; field = f2; name = s2 } ) ->
StructName.equal s1 s2 && StructFieldName.equal f1 f2 && equal e1 e2
StructName.equal s1 s2 && StructField.equal f1 f2 && equal e1 e2
| EInj { e = e1; cons = c1; name = n1 }, EInj { e = e2; cons = c2; name = n2 }
->
EnumName.equal n1 n2 && EnumConstructor.equal c1 c2 && equal e1 e2
@ -699,14 +711,14 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool =
EMatch { e = e2; name = n2; cases = cases2 } ) ->
EnumName.equal n1 n2
&& equal e1 e2
&& EnumConstructorMap.equal equal cases1 cases2
&& EnumConstructor.Map.equal equal cases1 cases2
| ( EScopeCall { scope = s1; args = fields1 },
EScopeCall { scope = s2; args = fields2 } ) ->
ScopeName.equal s1 s2 && ScopeVarMap.equal equal fields1 fields2
ScopeName.equal s1 s2 && ScopeVar.Map.equal equal fields1 fields2
| ( ( EVar _ | ETuple _ | ETupleAccess _ | EArray _ | ELit _ | EAbs _ | EApp _
| EAssert _ | EOp _ | EDefault _ | EIfThenElse _ | EErrorOnEmpty _
| ERaise _ | ECatch _ | ELocation _ | EStruct _ | EStructAccess _ | EInj _
| EMatch _ | EScopeCall _ ),
| ERaise _ | ECatch _ | ELocation _ | EStruct _ | EDStructAccess _
| EStructAccess _ | EInj _ | EMatch _ | EScopeCall _ ),
_ ) ->
false
@ -719,7 +731,7 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
match[@ocamlformat "disable"] Marked.unmark e1, Marked.unmark e2 with
| ELit l1, ELit l2 ->
compare_lit l1 l2
| EApp {f=f1; args= args1}, EApp {f=f2; args= args2} ->
| EApp {f=f1; args=args1}, EApp {f=f2; args=args2} ->
compare f1 f2 @@< fun () ->
List.compare compare args1 args2
| EOp op1, EOp op2 ->
@ -728,44 +740,57 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
List.compare compare a1 a2
| EVar v1, EVar v2 ->
Bindlib.compare_vars v1 v2
| EAbs {binder=binder1; tys= typs1}, EAbs {binder=binder2; tys= typs2} ->
| EAbs {binder=binder1; tys=typs1},
EAbs {binder=binder2; tys=typs2} ->
List.compare compare_typ typs1 typs2 @@< fun () ->
let _, e1, e2 = Bindlib.unmbind2 binder1 binder2 in
compare e1 e2
| EIfThenElse {cond=i1; etrue= t1; efalse= e1}, EIfThenElse {cond=i2; etrue= t2; efalse= e2} ->
| EIfThenElse {cond=i1; etrue=t1; efalse=e1},
EIfThenElse {cond=i2; etrue=t2; efalse=e2} ->
compare i1 i2 @@< fun () ->
compare t1 t2 @@< fun () ->
compare e1 e2
| ELocation l1, ELocation l2 ->
compare_location (Marked.mark Pos.no_pos l1) (Marked.mark Pos.no_pos l2)
| EStruct {name=name1; fields= field_map1}, EStruct {name=name2; fields= field_map2} ->
| EStruct {name=name1; fields=field_map1},
EStruct {name=name2; fields=field_map2} ->
StructName.compare name1 name2 @@< fun () ->
StructFieldMap.compare compare field_map1 field_map2
| EStructAccess {e=e1; field= field_name1; name= struct_name1},
EStructAccess {e=e2; field= field_name2; name= struct_name2} ->
StructField.Map.compare compare field_map1 field_map2
| EDStructAccess {e=e1; field=field_name1; name_opt=struct_name1},
EDStructAccess {e=e2; field=field_name2; name_opt=struct_name2} ->
compare e1 e2 @@< fun () ->
StructFieldName.compare field_name1 field_name2 @@< fun () ->
IdentName.compare field_name1 field_name2 @@< fun () ->
Option.compare StructName.compare struct_name1 struct_name2
| EStructAccess {e=e1; field=field_name1; name=struct_name1},
EStructAccess {e=e2; field=field_name2; name=struct_name2} ->
compare e1 e2 @@< fun () ->
StructField.compare field_name1 field_name2 @@< fun () ->
StructName.compare struct_name1 struct_name2
| EMatch {e=e1; name= name1;cases= emap1}, EMatch {e=e2; name= name2;cases= emap2} ->
| EMatch {e=e1; name=name1; cases=emap1},
EMatch {e=e2; name=name2; cases=emap2} ->
EnumName.compare name1 name2 @@< fun () ->
compare e1 e2 @@< fun () ->
EnumConstructorMap.compare compare emap1 emap2
| EScopeCall {scope=name1; args= field_map1}, EScopeCall {scope=name2; args= field_map2} ->
EnumConstructor.Map.compare compare emap1 emap2
| EScopeCall {scope=name1; args=field_map1},
EScopeCall {scope=name2; args=field_map2} ->
ScopeName.compare name1 name2 @@< fun () ->
ScopeVarMap.compare compare field_map1 field_map2
ScopeVar.Map.compare compare field_map1 field_map2
| ETuple es1, ETuple es2 ->
List.compare compare es1 es2
| ETupleAccess {e=e1; index= n1; size=s1}, ETupleAccess {e=e2; index= n2; size=s2} ->
| ETupleAccess {e=e1; index=n1; size=s1},
ETupleAccess {e=e2; index=n2; size=s2} ->
Int.compare s1 s2 @@< fun () ->
Int.compare n1 n2 @@< fun () ->
compare e1 e2
| EInj {e=e1; name= name1; cons= cons1}, EInj {e=e2; name= name2; cons= cons2} ->
| EInj {e=e1; name=name1; cons=cons1},
EInj {e=e2; name=name2; cons=cons2} ->
EnumName.compare name1 name2 @@< fun () ->
EnumConstructor.compare cons1 cons2 @@< fun () ->
compare e1 e2
| EAssert e1, EAssert e2 ->
compare e1 e2
| EDefault {excepts=exs1; just= just1; cons=cons1}, EDefault {excepts=exs2; just= just2; cons=cons2} ->
| EDefault {excepts=exs1; just=just1; cons=cons1},
EDefault {excepts=exs2; just=just2; cons=cons2} ->
compare just1 just2 @@< fun () ->
compare cons1 cons2 @@< fun () ->
List.compare compare exs1 exs2
@ -773,7 +798,8 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
compare e1 e2
| ERaise ex1, ERaise ex2 ->
compare_except ex1 ex2
| ECatch {body=etry1; exn= ex1; handler=ewith1}, ECatch {body=etry2; exn= ex2; handler=ewith2} ->
| ECatch {body=etry1; exn=ex1; handler=ewith1},
ECatch {body=etry2; exn=ex2; handler=ewith2} ->
compare_except ex1 ex2 @@< fun () ->
compare etry1 etry2 @@< fun () ->
compare ewith1 ewith2
@ -786,6 +812,7 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
| EIfThenElse _, _ -> -1 | _, EIfThenElse _ -> 1
| ELocation _, _ -> -1 | _, ELocation _ -> 1
| EStruct _, _ -> -1 | _, EStruct _ -> 1
| EDStructAccess _, _ -> -1 | _, EDStructAccess _ -> 1
| EStructAccess _, _ -> -1 | _, EStructAccess _ -> 1
| EMatch _, _ -> -1 | _, EMatch _ -> 1
| EScopeCall _, _ -> -1 | _, EScopeCall _ -> 1
@ -841,12 +868,13 @@ let rec size : type a. (a, 't) gexpr -> int =
| ECatch { body; handler; _ } -> 1 + size body + size handler
| ELocation _ -> 1
| EStruct { fields; _ } ->
StructFieldMap.fold (fun _ e acc -> acc + 1 + size e) fields 0
StructField.Map.fold (fun _ e acc -> acc + 1 + size e) fields 0
| EDStructAccess { e; _ } -> 1 + size e
| EStructAccess { e; _ } -> 1 + size e
| EMatch { e; cases; _ } ->
EnumConstructorMap.fold (fun _ e acc -> acc + 1 + size e) cases (size e)
EnumConstructor.Map.fold (fun _ e acc -> acc + 1 + size e) cases (size e)
| EScopeCall { args; _ } ->
ScopeVarMap.fold (fun _ e acc -> acc + 1 + size e) args 1
ScopeVar.Map.fold (fun _ e acc -> acc + 1 + size e) args 1
(* - Expression building helpers - *)
@ -931,3 +959,33 @@ let make_tuple el m0 =
(List.map (fun e -> Marked.get_mark e) el)
in
etuple el m
let translate_op_kind : type a. a op_kind -> 'b op_kind = function
| KInt -> KInt
| KRat -> KRat
| KMoney -> KMoney
| KDate -> KDate
| KDuration -> KDuration
let translate_op : type a. a operator -> 'b operator = function
| Ternop o -> Ternop o
| Binop o ->
Binop
(match o with
| Add k -> Add (translate_op_kind k)
| Sub k -> Sub (translate_op_kind k)
| Mult k -> Mult (translate_op_kind k)
| Div k -> Div (translate_op_kind k)
| Lt k -> Lt (translate_op_kind k)
| Lte k -> Lte (translate_op_kind k)
| Gt k -> Gt (translate_op_kind k)
| Gte k -> Gte (translate_op_kind k)
| (And | Or | Xor | Eq | Neq | Map | Concat | Filter) as o -> o)
| Unop o ->
Unop
(match o with
| Minus k -> Minus (translate_op_kind k)
| ( Not | Log _ | Length | IntToRat | MoneyToRat | RatToMoney | GetDay
| GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth | RoundMoney
| RoundDecimal ) as o ->
o)

34
compiler/shared_ast/expr.mli
View File

@ -17,7 +17,7 @@
(** Functions handling the expressions of [shared_ast] *)
open Utils
open Catala_utils
open Definitions
(** {2 Boxed constructors} *)
@ -66,7 +66,7 @@ val eapp :
val eassert :
(([< dcalc | lcalc ] as 'a), 't) boxed_gexpr -> 't -> ('a, 't) boxed_gexpr
val eop : operator -> 't -> (_ any, 't) boxed_gexpr
val eop : 'a any operator -> 't -> ('a, 't) boxed_gexpr
val edefault :
(([< desugared | scopelang | dcalc ] as 'a), 't) boxed_gexpr list ->
@ -101,13 +101,20 @@ val elocation :
val estruct :
StructName.t ->
('a any, 't) boxed_gexpr StructFieldMap.t ->
('a any, 't) boxed_gexpr StructField.Map.t ->
't ->
('a, 't) boxed_gexpr
val edstructaccess :
(desugared, 't) boxed_gexpr ->
IdentName.t ->
StructName.t option ->
't ->
(desugared, 't) boxed_gexpr
val estructaccess :
('a any, 't) boxed_gexpr ->
StructFieldName.t ->
(([< scopelang | dcalc | lcalc ] as 'a), 't) boxed_gexpr ->
StructField.t ->
StructName.t ->
't ->
('a, 't) boxed_gexpr
@ -122,13 +129,13 @@ val einj :
val ematch :
('a any, 't) boxed_gexpr ->
EnumName.t ->
('a, 't) boxed_gexpr EnumConstructorMap.t ->
('a, 't) boxed_gexpr EnumConstructor.Map.t ->
't ->
('a, 't) boxed_gexpr
val escopecall :
ScopeName.t ->
(([< desugared | scopelang ] as 'a), 't) boxed_gexpr ScopeVarMap.t ->
(([< desugared | scopelang ] as 'a), 't) boxed_gexpr ScopeVar.Map.t ->
't ->
('a, 't) boxed_gexpr
@ -303,6 +310,11 @@ val make_tuple :
(** {2 Transformations} *)
val translate_op :
[< desugared | scopelang | dcalc | lcalc ] operator -> 'b any operator
(** Operators are actually all the same after initial desambiguation, so this
function allows converting their types ; otherwise, this is the identity *)
val remove_logging_calls : ('a any, 't) gexpr -> ('a, 't) boxed_gexpr
(** Removes all calls to [Log] unary operators in the AST, replacing them by
their argument. *)
@ -360,10 +372,10 @@ module Box : sig
a separate argument. *)
val app1 :
('a, 't) boxed_gexpr ->
(('a, 't) gexpr -> ('a, 't) naked_gexpr) ->
't ->
('a, 't) boxed_gexpr
('a, 't1) boxed_gexpr ->
(('a, 't1) gexpr -> ('a, 't2) naked_gexpr) ->
't2 ->
('a, 't2) boxed_gexpr
val app2 :
('a, 't) boxed_gexpr ->

65
compiler/shared_ast/print.ml
View File

@ -14,8 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open String_common
open Catala_utils
open Definitions
let typ_needs_parens (ty : typ) : bool =
@ -26,27 +25,28 @@ let uid_list (fmt : Format.formatter) (infos : Uid.MarkedString.info list) :
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.pp_print_char fmt '.')
(fun fmt info ->
Utils.Cli.format_with_style
(if begins_with_uppercase (Marked.unmark info) then [ANSITerminal.red]
Cli.format_with_style
(if String.begins_with_uppercase (Marked.unmark info) then
[ANSITerminal.red]
else [])
fmt
(Utils.Uid.MarkedString.to_string info))
(Uid.MarkedString.to_string info))
fmt infos
let keyword (fmt : Format.formatter) (s : string) : unit =
Utils.Cli.format_with_style [ANSITerminal.red] fmt s
Cli.format_with_style [ANSITerminal.red] fmt s
let base_type (fmt : Format.formatter) (s : string) : unit =
Utils.Cli.format_with_style [ANSITerminal.yellow] fmt s
Cli.format_with_style [ANSITerminal.yellow] fmt s
let punctuation (fmt : Format.formatter) (s : string) : unit =
Utils.Cli.format_with_style [ANSITerminal.cyan] fmt s
Cli.format_with_style [ANSITerminal.cyan] fmt s
let operator (fmt : Format.formatter) (s : string) : unit =
Utils.Cli.format_with_style [ANSITerminal.green] fmt s
Cli.format_with_style [ANSITerminal.green] fmt s
let lit_style (fmt : Format.formatter) (s : string) : unit =
Utils.Cli.format_with_style [ANSITerminal.yellow] fmt s
Cli.format_with_style [ANSITerminal.yellow] fmt s
let tlit (fmt : Format.formatter) (l : typ_lit) : unit =
base_type fmt
@ -68,7 +68,7 @@ let location (type a) (fmt : Format.formatter) (l : a glocation) : unit =
ScopeVar.format_t (Marked.unmark subvar)
let enum_constructor (fmt : Format.formatter) (c : EnumConstructor.t) : unit =
Utils.Cli.format_with_style [ANSITerminal.magenta] fmt
Cli.format_with_style [ANSITerminal.magenta] fmt
(Format.asprintf "%a" EnumConstructor.format_t c)
let rec typ (ctx : decl_ctx option) (fmt : Format.formatter) (ty : typ) : unit =
@ -94,9 +94,9 @@ let rec typ (ctx : decl_ctx option) (fmt : Format.formatter) (ty : typ) : unit =
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " punctuation ";")
(fun fmt (field, mty) ->
Format.fprintf fmt "%a%a%a%a@ %a" punctuation "\""
StructFieldName.format_t field punctuation "\"" punctuation ":"
typ mty))
(StructFieldMap.bindings (StructMap.find s ctx.ctx_structs))
StructField.format_t field punctuation "\"" punctuation ":" typ
mty))
(StructField.Map.bindings (StructName.Map.find s ctx.ctx_structs))
punctuation "}")
| TEnum e -> (
match ctx with
@ -109,7 +109,7 @@ let rec typ (ctx : decl_ctx option) (fmt : Format.formatter) (ty : typ) : unit =
(fun fmt (case, mty) ->
Format.fprintf fmt "%a%a@ %a" enum_constructor case punctuation ":"
typ mty))
(EnumConstructorMap.bindings (EnumMap.find e ctx.ctx_enums))
(EnumConstructor.Map.bindings (EnumName.Map.find e ctx.ctx_enums))
punctuation "]")
| TOption t -> Format.fprintf fmt "@[<hov 2>%a@ %a@]" base_type "option" typ t
| TArrow (t1, t2) ->
@ -127,9 +127,9 @@ let lit (type a) (fmt : Format.formatter) (l : a glit) : unit =
| LUnit -> lit_style fmt "()"
| LRat i ->
lit_style fmt
(Runtime.decimal_to_string ~max_prec_digits:!Utils.Cli.max_prec_digits i)
(Runtime.decimal_to_string ~max_prec_digits:!Cli.max_prec_digits i)
| LMoney e -> (
match !Utils.Cli.locale_lang with
match !Cli.locale_lang with
| En -> lit_style fmt (Format.asprintf "$%s" (Runtime.money_to_string e))
| Fr -> lit_style fmt (Format.asprintf "%s €" (Runtime.money_to_string e))
| Pl -> lit_style fmt (Format.asprintf "%s PLN" (Runtime.money_to_string e))
@ -137,7 +137,7 @@ let lit (type a) (fmt : Format.formatter) (l : a glit) : unit =
| LDate d -> lit_style fmt (Runtime.date_to_string d)
| LDuration d -> lit_style fmt (Runtime.duration_to_string d)
let op_kind (fmt : Format.formatter) (k : op_kind) =
let op_kind (fmt : Format.formatter) (k : 'a op_kind) =
Format.fprintf fmt "%s"
(match k with
| KInt -> ""
@ -146,7 +146,7 @@ let op_kind (fmt : Format.formatter) (k : op_kind) =
| KDate -> "@"
| KDuration -> "^")
let binop (fmt : Format.formatter) (op : binop) : unit =
let binop (fmt : Format.formatter) (op : 'a binop) : unit =
operator fmt
(match op with
| Add k -> Format.asprintf "+%a" op_kind k
@ -172,14 +172,14 @@ let ternop (fmt : Format.formatter) (op : ternop) : unit =
let log_entry (fmt : Format.formatter) (entry : log_entry) : unit =
Format.fprintf fmt "@<2>%a"
(fun fmt -> function
| VarDef _ -> Utils.Cli.format_with_style [ANSITerminal.blue] fmt "≔ "
| BeginCall -> Utils.Cli.format_with_style [ANSITerminal.yellow] fmt "→ "
| EndCall -> Utils.Cli.format_with_style [ANSITerminal.yellow] fmt "← "
| VarDef _ -> Cli.format_with_style [ANSITerminal.blue] fmt "≔ "
| BeginCall -> Cli.format_with_style [ANSITerminal.yellow] fmt "→ "
| EndCall -> Cli.format_with_style [ANSITerminal.yellow] fmt "← "
| PosRecordIfTrueBool ->
Utils.Cli.format_with_style [ANSITerminal.green] fmt "☛ ")
Cli.format_with_style [ANSITerminal.green] fmt "☛ ")
entry
let unop (fmt : Format.formatter) (op : unop) : unit =
let unop (fmt : Format.formatter) (op : 'a unop) : unit =
match op with
| Minus _ -> Format.pp_print_string fmt "-"
| Not -> Format.pp_print_string fmt "~"
@ -187,7 +187,7 @@ let unop (fmt : Format.formatter) (op : unop) : unit =
Format.fprintf fmt "log@[<hov 2>[%a|%a]@]" log_entry entry
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ".")
(fun fmt info -> Utils.Uid.MarkedString.format_info fmt info))
(fun fmt info -> Uid.MarkedString.format fmt info))
infos
| Length -> Format.pp_print_string fmt "length"
| IntToRat -> Format.pp_print_string fmt "int_to_rat"
@ -323,6 +323,9 @@ let rec expr_aux :
| ERaise exn ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" keyword "raise" except exn
| ELocation loc -> location fmt loc
| EDStructAccess { e; field; _ } ->
Format.fprintf fmt "%a%a%a%a%a" expr e punctuation "." punctuation "\""
IdentName.format_t field punctuation "\""
| EStruct { name; fields } ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@]" StructName.format_t name
punctuation "{"
@ -330,13 +333,13 @@ let rec expr_aux :
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " punctuation ";")
(fun fmt (field_name, field_expr) ->
Format.fprintf fmt "%a%a%a%a@ %a" punctuation "\""
StructFieldName.format_t field_name punctuation "\"" punctuation
"=" expr field_expr))
(StructFieldMap.bindings fields)
StructField.format_t field_name punctuation "\"" punctuation "="
expr field_expr))
(StructField.Map.bindings fields)
punctuation "}"
| EStructAccess { e; field; _ } ->
Format.fprintf fmt "%a%a%a%a%a" expr e punctuation "." punctuation "\""
StructFieldName.format_t field punctuation "\""
StructField.format_t field punctuation "\""
| EInj { e; cons; _ } ->
Format.fprintf fmt "%a@ %a" EnumConstructor.format_t cons expr e
| EMatch { e; cases; _ } ->
@ -347,7 +350,7 @@ let rec expr_aux :
(fun fmt (cons_name, case_expr) ->
Format.fprintf fmt "@[<hov 2>%a %a@ %a@ %a@]" punctuation "|"
enum_constructor cons_name punctuation "→" expr case_expr))
(EnumConstructorMap.bindings cases)
(EnumConstructor.Map.bindings cases)
| EScopeCall { scope; args } ->
Format.pp_open_hovbox fmt 2;
ScopeName.format_t fmt scope;
@ -362,7 +365,7 @@ let rec expr_aux :
Format.fprintf fmt "%a%a%a%a@ %a" punctuation "\"" ScopeVar.format_t
field_name punctuation "\"" punctuation "=" expr field_expr)
fmt
(ScopeVarMap.bindings args);
(ScopeVar.Map.bindings args);
Format.pp_close_box fmt ();
punctuation fmt "}";
Format.pp_close_box fmt ()

8
compiler/shared_ast/print.mli
View File

@ -16,7 +16,7 @@
(** Printing functions for the default calculus AST *)
open Utils
open Catala_utils
open Definitions
(** {1 Common syntax highlighting helpers}*)
@ -35,11 +35,11 @@ val tlit : Format.formatter -> typ_lit -> unit
val location : Format.formatter -> 'a glocation -> unit
val typ : decl_ctx -> Format.formatter -> typ -> unit
val lit : Format.formatter -> 'a glit -> unit
val op_kind : Format.formatter -> op_kind -> unit
val binop : Format.formatter -> binop -> unit
val op_kind : Format.formatter -> 'a any op_kind -> unit
val binop : Format.formatter -> 'a any binop -> unit
val ternop : Format.formatter -> ternop -> unit
val log_entry : Format.formatter -> log_entry -> unit
val unop : Format.formatter -> unop -> unit
val unop : Format.formatter -> 'a any unop -> unit
val except : Format.formatter -> except -> unit
val var : Format.formatter -> 'e Var.t -> unit
val var_debug : Format.formatter -> 'e Var.t -> unit

4
compiler/shared_ast/scope.ml
View File

@ -15,7 +15,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
open Definitions
let rec fold_left_lets ~f ~init scope_body_expr =
@ -106,7 +106,7 @@ let rec get_body_expr_mark = function
get_body_expr_mark e
| Result e ->
let m = Marked.get_mark e in
Expr.with_ty m (Utils.Marked.mark (Expr.mark_pos m) TAny)
Expr.with_ty m (Marked.mark (Expr.mark_pos m) TAny)
let get_body_mark scope_body =
let _, e = Bindlib.unbind scope_body.scope_body_expr in

2
compiler/shared_ast/scope.mli
View File

@ -17,7 +17,7 @@
(** Functions handling the scope structures of [shared_ast] *)
open Utils
open Catala_utils
open Definitions
(** {2 Traversal functions} *)

200
compiler/shared_ast/typing.ml
View File

@ -17,16 +17,16 @@
(** Typing for the default calculus. Because of the error terms, we perform type
inference using the classical W algorithm with union-find unification. *)
open Utils
open Catala_utils
module A = Definitions
module Any =
Utils.Uid.Make
Uid.Make
(struct
type info = unit
let to_string _ = "any"
let format_info fmt () = Format.fprintf fmt "any"
let format fmt () = Format.fprintf fmt "any"
let equal _ _ = true
let compare _ _ = 0
end)
@ -47,7 +47,8 @@ and naked_typ =
| TArray of unionfind_typ
| TAny of Any.t
let rec typ_to_ast (ty : unionfind_typ) : A.typ =
let rec typ_to_ast ?(unsafe = false) (ty : unionfind_typ) : A.typ =
let typ_to_ast = typ_to_ast ~unsafe in
let ty, pos = UnionFind.get (UnionFind.find ty) in
match ty with
| TLit l -> A.TLit l, pos
@ -58,11 +59,22 @@ let rec typ_to_ast (ty : unionfind_typ) : A.typ =
| TArrow (t1, t2) -> A.TArrow (typ_to_ast t1, typ_to_ast t2), pos
| TArray t1 -> A.TArray (typ_to_ast t1), pos
| TAny _ ->
(* No polymorphism in Catala: type inference should return full types
without wildcards, and this function is used to recover the types after
typing. *)
Errors.raise_spanned_error pos
"Internal error: typing at this point could not be resolved"
if unsafe then A.TAny, pos
else
(* No polymorphism in Catala: type inference should return full types
without wildcards, and this function is used to recover the types after
typing. *)
Errors.raise_spanned_error pos
"Internal error: typing at this point could not be resolved"
(* Checks that there are no type variables remaining *)
let rec all_resolved ty =
match Marked.unmark (UnionFind.get (UnionFind.find ty)) with
| TAny _ -> false
| TLit _ | TStruct _ | TEnum _ -> true
| TOption t1 | TArray t1 -> all_resolved t1
| TArrow (t1, t2) -> all_resolved t1 && all_resolved t2
| TTuple ts -> List.for_all all_resolved ts
let rec ast_to_typ (ty : A.typ) : unionfind_typ =
let ty' =
@ -111,9 +123,11 @@ let rec format_typ
format_typ t2
| TArray t1 -> (
match Marked.unmark (UnionFind.get (UnionFind.find t1)) with
| TAny _ -> Format.pp_print_string fmt "collection"
| TAny _ when not !Cli.debug_flag -> Format.pp_print_string fmt "collection"
| _ -> Format.fprintf fmt "@[collection@ %a@]" format_typ t1)
| TAny _ -> Format.pp_print_string fmt "<any>"
| TAny v ->
if !Cli.debug_flag then Format.fprintf fmt "<a%d>" (Any.hash v)
else Format.pp_print_string fmt "<any>"
exception Type_error of A.any_expr * unionfind_typ * unionfind_typ
@ -215,7 +229,7 @@ let lit_type (type a) (lit : a A.glit) : naked_typ =
This allows us to have a simpler type system, while we argue the syntactic
burden of operator annotations helps the programmer visualize the type flow
in the code. *)
let op_type (op : A.operator Marked.pos) : unionfind_typ =
let op_type (op : 'a A.operator Marked.pos) : unionfind_typ =
let pos = Marked.get_mark op in
let bt = UnionFind.make (TLit TBool, pos) in
let it = UnionFind.make (TLit TInt, pos) in
@ -284,32 +298,41 @@ let op_type (op : A.operator Marked.pos) : unionfind_typ =
module Env = struct
type 'e t = {
vars : ('e, unionfind_typ) Var.Map.t;
scope_vars : A.typ A.ScopeVarMap.t;
scopes : A.typ A.ScopeVarMap.t A.ScopeMap.t;
scope_vars : A.typ A.ScopeVar.Map.t;
scopes : A.typ A.ScopeVar.Map.t A.ScopeName.Map.t;
}
let empty =
{
vars = Var.Map.empty;
scope_vars = A.ScopeVarMap.empty;
scopes = A.ScopeMap.empty;
scope_vars = A.ScopeVar.Map.empty;
scopes = A.ScopeName.Map.empty;
}
let get t v = Var.Map.find_opt v t.vars
let get_scope_var t sv = A.ScopeVarMap.find_opt sv t.scope_vars
let get_scope_var t sv = A.ScopeVar.Map.find_opt sv t.scope_vars
let get_subscope_out_var t scope var =
Option.bind (A.ScopeMap.find_opt scope t.scopes) (fun vmap ->
A.ScopeVarMap.find_opt var vmap)
Option.bind (A.ScopeName.Map.find_opt scope t.scopes) (fun vmap ->
A.ScopeVar.Map.find_opt var vmap)
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_scope_var v typ t =
{ t with scope_vars = A.ScopeVarMap.add v typ t.scope_vars }
{ t with scope_vars = A.ScopeVar.Map.add v typ t.scope_vars }
let add_scope scope_name ~vars t =
{ t with scopes = A.ScopeMap.add scope_name vars t.scopes }
{ t with scopes = A.ScopeName.Map.add scope_name vars t.scopes }
let open_scope scope_name t =
let scope_vars =
A.ScopeVar.Map.union
(fun _ _ -> assert false)
t.scope_vars
(A.ScopeName.Map.find scope_name t.scopes)
in
{ t with scope_vars }
end
let add_pos e ty = Marked.mark (Expr.pos e) ty
@ -373,33 +396,32 @@ and typecheck_expr_top_down :
Expr.elocation loc (uf_mark (ast_to_typ ty))
| A.EStruct { name; fields } ->
let mark = ty_mark (TStruct name) in
let str = A.StructMap.find name ctx.A.ctx_structs in
let str = A.StructName.Map.find name ctx.A.ctx_structs in
let _check_fields : unit =
let missing_fields, extra_fields =
A.StructFieldMap.fold
A.StructField.Map.fold
(fun fld x (remaining, extra) ->
if A.StructFieldMap.mem fld remaining then
A.StructFieldMap.remove fld remaining, extra
else remaining, A.StructFieldMap.add fld x extra)
if A.StructField.Map.mem fld remaining then
A.StructField.Map.remove fld remaining, extra
else remaining, A.StructField.Map.add fld x extra)
fields
(str, A.StructFieldMap.empty)
(str, A.StructField.Map.empty)
in
let errs =
List.map
(fun (f, ty) ->
( Some
(Format.asprintf "Missing field %a" A.StructFieldName.format_t f),
( Some (Format.asprintf "Missing field %a" A.StructField.format_t f),
Marked.get_mark ty ))
(A.StructFieldMap.bindings missing_fields)
(A.StructField.Map.bindings missing_fields)
@ List.map
(fun (f, ef) ->
let dup = A.StructFieldMap.mem f str in
let dup = A.StructField.Map.mem f str in
( Some
(Format.asprintf "%s field %a"
(if dup then "Duplicate" else "Unknown")
A.StructFieldName.format_t f),
A.StructField.format_t f),
Expr.pos ef ))
(A.StructFieldMap.bindings extra_fields)
(A.StructField.Map.bindings extra_fields)
in
if errs <> [] then
Errors.raise_multispanned_error errs
@ -407,22 +429,62 @@ and typecheck_expr_top_down :
name
in
let fields' =
A.StructFieldMap.mapi
A.StructField.Map.mapi
(fun f_name f_e ->
let f_ty = A.StructFieldMap.find f_name str in
let f_ty = A.StructField.Map.find f_name str in
typecheck_expr_top_down ctx env (ast_to_typ f_ty) f_e)
fields
in
Expr.estruct name fields' mark
| A.EStructAccess { e = e_struct; name; field } ->
| A.EDStructAccess { e = e_struct; name_opt; field } ->
let t_struct =
match name_opt with
| Some name -> TStruct name
| None -> TAny (Any.fresh ())
in
let e_struct' =
typecheck_expr_top_down ctx env (unionfind t_struct) e_struct
in
let name =
match UnionFind.get (ty e_struct') with
| TStruct name, _ -> name
| TAny _, _ ->
Printf.ksprintf failwith
"Disambiguation failed before reaching field %s" field
| _ ->
Errors.raise_spanned_error (Expr.pos e)
"This is not a structure, cannot access field %s (%a)" field
(format_typ ctx) (ty e_struct')
in
let fld_ty =
let str =
try A.StructMap.find name ctx.A.ctx_structs
try A.StructName.Map.find name ctx.A.ctx_structs
with Not_found ->
Errors.raise_spanned_error pos_e "No structure %a found"
A.StructName.format_t name
in
try A.StructFieldMap.find field str
let field =
try
A.StructName.Map.find name
(A.IdentName.Map.find field ctx.ctx_struct_fields)
with Not_found ->
Errors.raise_spanned_error context_mark.pos
"Field %s does not belong to structure %a" field
A.StructName.format_t name
in
A.StructField.Map.find field str
in
let mark = uf_mark (ast_to_typ fld_ty) in
Expr.edstructaccess e_struct' field (Some name) mark
| A.EStructAccess { e = e_struct; name; field } ->
let fld_ty =
let str =
try A.StructName.Map.find name ctx.A.ctx_structs
with Not_found ->
Errors.raise_spanned_error pos_e "No structure %a found"
A.StructName.format_t name
in
try A.StructField.Map.find field str
with Not_found ->
Errors.raise_multispanned_error
[
@ -431,7 +493,7 @@ and typecheck_expr_top_down :
Marked.get_mark (A.StructName.get_info name) );
]
"Structure %a doesn't define a field %a" A.StructName.format_t name
A.StructFieldName.format_t field
A.StructField.format_t field
in
let mark = uf_mark (ast_to_typ fld_ty) in
let e_struct' =
@ -443,20 +505,20 @@ and typecheck_expr_top_down :
let e_enum' =
typecheck_expr_top_down ctx env
(ast_to_typ
(A.EnumConstructorMap.find cons
(A.EnumMap.find name ctx.A.ctx_enums)))
(A.EnumConstructor.Map.find cons
(A.EnumName.Map.find name ctx.A.ctx_enums)))
e_enum
in
Expr.einj e_enum' cons name mark
| A.EMatch { e = e1; name; cases } ->
let cases_ty = A.EnumMap.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 mark = uf_mark t_ret in
let e1' = typecheck_expr_top_down ctx env (unionfind (TEnum name)) e1 in
let cases' =
A.EnumConstructorMap.mapi
A.EnumConstructor.Map.mapi
(fun c_name e ->
let c_ty = A.EnumConstructorMap.find c_name cases_ty in
let c_ty = A.EnumConstructor.Map.find c_name cases_ty in
let e_ty = unionfind ~pos:e (TArrow (ast_to_typ c_ty, t_ret)) in
typecheck_expr_top_down ctx env e_ty e)
cases
@ -464,15 +526,15 @@ and typecheck_expr_top_down :
Expr.ematch e1' name cases' mark
| A.EScopeCall { scope; args } ->
let scope_out_struct =
(A.ScopeMap.find scope ctx.ctx_scopes).out_struct_name
(A.ScopeName.Map.find scope ctx.ctx_scopes).out_struct_name
in
let mark = uf_mark (unionfind (TStruct scope_out_struct)) in
let vars = A.ScopeMap.find scope env.scopes in
let vars = A.ScopeName.Map.find scope env.scopes in
let args' =
A.ScopeVarMap.mapi
A.ScopeVar.Map.mapi
(fun name ->
typecheck_expr_top_down ctx env
(ast_to_typ (A.ScopeVarMap.find name vars)))
(ast_to_typ (A.ScopeVar.Map.find name vars)))
args
in
Expr.escopecall scope args' mark
@ -522,6 +584,7 @@ and typecheck_expr_top_down :
tau_args t_ret
in
let mark = uf_mark t_func in
assert (List.for_all all_resolved tau_args);
let xs, body = Bindlib.unmbind binder in
let xs' = Array.map Var.translate xs in
let env =
@ -532,7 +595,13 @@ and typecheck_expr_top_down :
let body' = typecheck_expr_top_down ctx env t_ret body in
let binder' = Bindlib.bind_mvar xs' (Expr.Box.lift body') in
Expr.eabs binder' (List.map typ_to_ast tau_args) mark
| A.EApp { f = e1; args } ->
| A.EApp { f = (EOp _, _) as e1; args } ->
(* Same as EApp, but the typing order is different to help with
disambiguation: - type of the operator is extracted first (to figure
linked type vars between arguments) - arguments are typed right-to-left,
because our operators with function args always have the functions first,
and the argument types of those functions can always be inferred from the
later operator arguments *)
let t_args = List.map (fun _ -> unionfind (TAny (Any.fresh ()))) args in
let t_func =
List.fold_right
@ -540,7 +609,24 @@ and typecheck_expr_top_down :
t_args tau
in
let e1' = typecheck_expr_top_down ctx env t_func e1 in
let args' =
List.rev_map2
(typecheck_expr_top_down ctx env)
(List.rev t_args) (List.rev args)
in
Expr.eapp e1' args' context_mark
| A.EApp { f = e1; args } ->
(* Here we type the arguments first (in order), to ensure we know the types
of the arguments if [f] is [EAbs] before disambiguation. This is also the
right order for the [let-in] form. *)
let t_args = List.map (fun _ -> unionfind (TAny (Any.fresh ()))) args in
let t_func =
List.fold_right
(fun t_arg acc -> unionfind (TArrow (t_arg, acc)))
t_args tau
in
let args' = List.map2 (typecheck_expr_top_down ctx env) t_args args in
let e1' = typecheck_expr_top_down ctx env t_func e1 in
Expr.eapp e1' args' context_mark
| A.EOp op -> Expr.eop op (uf_mark (op_type (Marked.mark pos_e op)))
| A.EDefault { excepts; just; cons } ->
@ -588,19 +674,27 @@ let wrap_expr ctx f e =
let get_ty_mark { uf; pos } = A.Typed { ty = typ_to_ast uf; pos }
(* Infer the type of an expression *)
let expr
let expr_raw
(type a)
(ctx : A.decl_ctx)
?(env = Env.empty)
?(typ : A.typ option)
(e : (a, 'm) A.gexpr) : (a, A.typed A.mark) A.boxed_gexpr =
(e : (a, 'm) A.gexpr) : (a, mark) A.gexpr =
let fty =
match typ with
| None -> typecheck_expr_bottom_up ctx env
| Some typ -> typecheck_expr_top_down ctx env (ast_to_typ typ)
in
Expr.map_marks ~f:get_ty_mark (wrap_expr ctx fty e)
wrap_expr ctx fty e
let check_expr ctx ?env ?typ e =
Expr.map_marks
~f:(fun { pos; _ } -> A.Untyped { pos })
(expr_raw ctx ?env ?typ e)
(* Infer the type of an expression *)
let expr ctx ?env ?typ e =
Expr.map_marks ~f:get_ty_mark (expr_raw ctx ?env ?typ e)
let rec scope_body_expr ctx env ty_out body_expr =
match body_expr with

14
compiler/shared_ast/typing.mli
View File

@ -25,7 +25,8 @@ module Env : sig
val empty : 'e t
val add_var : 'e Var.t -> typ -> 'e t -> 'e t
val add_scope_var : ScopeVar.t -> typ -> 'e t -> 'e t
val add_scope : ScopeName.t -> vars:typ ScopeVarMap.t -> 'e t -> 'e t
val add_scope : ScopeName.t -> vars:typ ScopeVar.Map.t -> 'e t -> 'e t
val open_scope : ScopeName.t -> 'e t -> 'e t
end
val expr :
@ -43,6 +44,17 @@ val expr :
filling the gaps ([TAny]) if any. Use [Expr.untype] first if this is not
what you want. *)
val check_expr :
decl_ctx ->
?env:'e Env.t ->
?typ:typ ->
(('a, 'm mark) gexpr as 'e) ->
('a, untyped mark) boxed_gexpr
(** Same as [expr], but doesn't annotate the returned expression. Equivalent to
[Typing.expr |> Expr.untype], but more efficient. This can be useful for
type-checking and disambiguation (some AST nodes are updated with missing
information, e.g. any [TAny] appearing in the AST is replaced) *)
val program : ('a, 'm mark) gexpr program -> ('a, typed mark) gexpr program
(** Typing on whole programs (as defined in Shared_ast.program, i.e. for the
later dcalc/lcalc stages.

2
compiler/surface/ast.ml
View File

@ -19,7 +19,7 @@
[@@@ocaml.warning "-7"]
open Utils
open Catala_utils
(** {1 Visitor classes for programs} *)
(** To allow for quick traversal and/or modification of this AST structure, we

2
compiler/surface/dune
View File

@ -2,7 +2,7 @@
(name surface)
(public_name catala.surface)
(libraries
utils
catala_utils
menhirLib
sedlex
re

2
compiler/surface/fill_positions.ml
View File

@ -14,7 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
let fill_pos_with_legislative_info (p : Ast.program) : Ast.program =
let visitor =

2
compiler/surface/lexer.cppo.ml
View File

@ -14,7 +14,7 @@
open Tokens
open Sedlexing
open Utils
open Catala_utils
module L = Lexer_common
module R = Re.Pcre

2
compiler/surface/lexer_common.ml
View File

@ -17,7 +17,7 @@
open Tokens
open Sedlexing
open Utils
open Catala_utils
module R = Re.Pcre
(* Calculates the precedence according a {!val: matched_regex} of the form :

2
compiler/surface/lexer_common.mli
View File

@ -31,7 +31,7 @@ val code_buffer : Buffer.t
val update_acc : Sedlexing.lexbuf -> unit
(** Updates {!val:code_buffer} with the current lexeme *)
val raise_lexer_error : Utils.Pos.t -> string -> 'a
val raise_lexer_error : Catala_utils.Pos.t -> string -> 'a
(** Error-generating helper *)
val token_list_language_agnostic : (string * Tokens.token) list

2
compiler/surface/parser.mly
View File

@ -18,7 +18,7 @@
*)
%{
open Utils
open Catala_utils
%}
%parameter<Localisation: sig

2
compiler/surface/parser_driver.ml
View File

@ -19,7 +19,7 @@
Parser_driver.parse_source_file} API. *)
open Sedlexing
open Utils
open Catala_utils
(** {1 Internal functions} *)

2
compiler/surface/parser_driver.mli
View File

@ -17,6 +17,6 @@
(** Wrapping module around parser and lexer that offers the
[Surface.Parser_driver.parse_source_file] API. *)
open Utils
open Catala_utils
val parse_top_level_file : Pos.input_file -> Cli.backend_lang -> Ast.program

2
compiler/verification/conditions.ml
View File

@ -15,7 +15,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
open Shared_ast
open Dcalc
open Ast

2
compiler/verification/conditions.mli
View File

@ -17,7 +17,7 @@
(** Generates verification conditions from scope definitions *)
open Utils
open Catala_utils
open Shared_ast
type verification_condition_kind =

2
compiler/verification/dune
View File

@ -3,7 +3,7 @@
(public_name catala.verification)
(libraries
bindlib
utils
catala_utils
dcalc
catala.runtime_ocaml
dates_calc

2
compiler/verification/io.ml
View File

@ -15,7 +15,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
open Shared_ast
module type Backend = sig

4
compiler/verification/solver.ml
View File

@ -14,6 +14,8 @@
License for the specific language governing permissions and limitations under
the License. *)
open Catala_utils
(** [solve_vc] is the main entry point of this module. It takes a list of
expressions [vcs] corresponding to verification conditions that must be
discharged by Z3, and attempts to solve them **)
@ -45,4 +47,4 @@ let solve_vc
true z3_vcs
in
if all_proven then
Utils.Cli.result_format "No errors found during the proof mode run."
Cli.result_format "No errors found during the proof mode run."

3
compiler/verification/z3backend.dummy.ml
View File

@ -18,7 +18,7 @@
without the expected backend. All functions print an error message and exit *)
let dummy () =
Utils.Cli.error_print
Catala_utils.Cli.error_print
"This instance of Catala was compiled without Z3 support.";
exit 124
@ -36,7 +36,6 @@ module Io = struct
type model = unit
type vc_encoding_result = Success of model * model | Fail of string
let print_positive_result _ = dummy ()
let print_negative_result _ _ _ = dummy ()
let encode_and_check_vc _ _ = dummy ()
end

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

@ -14,7 +14,7 @@
License for the specific language governing permissions and limitations under
the License. *)
open Utils
open Catala_utils
open Shared_ast
open Dcalc
open Ast
@ -35,13 +35,13 @@ type context = {
(* A map from strings, corresponding to Z3 symbol names, to the Catala
variable they represent. Used when to pretty-print Z3 models when a
counterexample is generated *)
ctx_z3datatypes : Sort.sort EnumMap.t;
ctx_z3datatypes : Sort.sort EnumName.Map.t;
(* A map from Catala enumeration names to the corresponding Z3 sort, from
which we can retrieve constructors and accessors *)
ctx_z3matchsubsts : (typed expr, Expr.expr) Var.Map.t;
(* A map from Catala temporary variables, generated when translating a match,
to the corresponding enum accessor call as a Z3 expression *)
ctx_z3structs : Sort.sort StructMap.t;
ctx_z3structs : Sort.sort StructName.Map.t;
(* A map from Catala struct names to the corresponding Z3 sort, from which we
can retrieve the constructor and the accessors *)
ctx_z3unit : Sort.sort * Expr.expr;
@ -80,7 +80,7 @@ let add_z3var (name : string) (v : typed expr Var.t) (ty : typ) (ctx : context)
corresponding Z3 datatype [sort] to the context **)
let add_z3enum (enum : EnumName.t) (sort : Sort.sort) (ctx : context) : context
=
{ ctx with ctx_z3datatypes = EnumMap.add enum sort ctx.ctx_z3datatypes }
{ ctx with ctx_z3datatypes = EnumName.Map.add enum sort ctx.ctx_z3datatypes }
(** [add_z3matchsubst] adds the mapping between temporary variable [v] and the
Z3 expression [e] representing an accessor application to the context **)
@ -92,7 +92,7 @@ let add_z3matchsubst (v : typed expr Var.t) (e : Expr.expr) (ctx : context) :
corresponding Z3 datatype [sort] to the context **)
let add_z3struct (s : StructName.t) (sort : Sort.sort) (ctx : context) : context
=
{ ctx with ctx_z3structs = StructMap.add s sort ctx.ctx_z3structs }
{ ctx with ctx_z3structs = StructName.Map.add s sort ctx.ctx_z3structs }
let add_z3constraint (e : Expr.expr) (ctx : context) : context =
{ ctx with ctx_z3constraints = e :: ctx.ctx_z3constraints }
@ -161,16 +161,16 @@ let rec print_z3model_expr (ctx : context) (ty : typ) (e : Expr.expr) : string =
match Marked.unmark ty with
| TLit ty -> print_lit ty
| TStruct name ->
let s = StructMap.find name ctx.ctx_decl.ctx_structs in
let get_fieldname (fn : StructFieldName.t) : string =
Marked.unmark (StructFieldName.get_info fn)
let s = StructName.Map.find name ctx.ctx_decl.ctx_structs in
let get_fieldname (fn : StructField.t) : string =
Marked.unmark (StructField.get_info fn)
in
let fields =
List.map2
(fun (fn, ty) e ->
Format.asprintf "-- %s : %s" (get_fieldname fn)
(print_z3model_expr ctx ty e))
(StructFieldMap.bindings s)
(StructField.Map.bindings s)
(Expr.get_args e)
in
@ -187,13 +187,13 @@ let rec print_z3model_expr (ctx : context) (ty : typ) (e : Expr.expr) : string =
let fd = Expr.get_func_decl e in
let fd_name = Symbol.to_string (FuncDecl.get_name fd) in
let enum_ctrs = EnumMap.find name ctx.ctx_decl.ctx_enums in
let enum_ctrs = EnumName.Map.find name ctx.ctx_decl.ctx_enums in
let case =
List.find
(fun (ctr, _) ->
(* FIXME: don't match on strings *)
String.equal fd_name (Marked.unmark (EnumConstructor.get_info ctr)))
(EnumConstructorMap.bindings enum_ctrs)
(EnumConstructor.Map.bindings enum_ctrs)
in
Format.asprintf "%s (%s)" fd_name (print_z3model_expr ctx (snd case) e')
@ -310,12 +310,12 @@ and find_or_create_enum (ctx : context) (enum : EnumName.t) :
[Sort.get_id arg_z3_ty] )
in
match EnumMap.find_opt enum ctx.ctx_z3datatypes with
match EnumName.Map.find_opt enum ctx.ctx_z3datatypes with
| Some e -> ctx, e
| None ->
let ctrs = EnumMap.find enum ctx.ctx_decl.ctx_enums in
let ctrs = EnumName.Map.find enum ctx.ctx_decl.ctx_enums in
let ctx, z3_ctrs =
EnumConstructorMap.fold
EnumConstructor.Map.fold
(fun ctr ty (ctx, ctrs) ->
let ctx, ctr = create_constructor ctr ty ctx in
ctx, ctr :: ctrs)
@ -334,20 +334,20 @@ and find_or_create_enum (ctx : context) (enum : EnumName.t) :
context *)
and find_or_create_struct (ctx : context) (s : StructName.t) :
context * Sort.sort =
match StructMap.find_opt s ctx.ctx_z3structs with
match StructName.Map.find_opt s ctx.ctx_z3structs with
| Some s -> ctx, s
| None ->
let s_name = Marked.unmark (StructName.get_info s) in
let fields = StructMap.find s ctx.ctx_decl.ctx_structs in
let fields = StructName.Map.find s ctx.ctx_decl.ctx_structs in
let z3_fieldnames =
List.map
(fun f ->
Marked.unmark (StructFieldName.get_info (fst f))
Marked.unmark (StructField.get_info (fst f))
|> Symbol.mk_string ctx.ctx_z3)
(StructFieldMap.bindings fields)
(StructField.Map.bindings fields)
in
let ctx, z3_fieldtypes_rev =
StructFieldMap.fold
StructField.Map.fold
(fun _ ty (ctx, ftypes) ->
let ctx, ftype = translate_typ ctx (Marked.unmark ty) in
ctx, ftype :: ftypes)
@ -426,8 +426,8 @@ let is_leap_year = Runtime.is_leap_year
(** [translate_op] returns the Z3 expression corresponding to the application of
[op] to the arguments [args] **)
let rec translate_op (ctx : context) (op : operator) (args : 'm expr list) :
context * Expr.expr =
let rec translate_op (ctx : context) (op : dcalc operator) (args : 'm expr list)
: context * Expr.expr =
match op with
| Ternop _top ->
let _e1, _e2, _e3 =
@ -709,14 +709,12 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
let idx_mappings =
List.combine
(List.map fst
(StructFieldMap.bindings
(StructMap.find name ctx.ctx_decl.ctx_structs)))
(StructField.Map.bindings
(StructName.Map.find name ctx.ctx_decl.ctx_structs)))
accessors
in
let _, accessor =
List.find
(fun (field1, _) -> StructFieldName.equal field field1)
idx_mappings
List.find (fun (field1, _) -> StructField.equal field field1) idx_mappings
in
let ctx, s = translate_expr ctx e in
ctx, Expr.mk_app ctx.ctx_z3 accessor [s]
@ -730,8 +728,8 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
let idx_mappings =
List.combine
(List.map fst
(EnumConstructorMap.bindings
(EnumMap.find name ctx.ctx_decl.ctx_enums)))
(EnumConstructor.Map.bindings
(EnumName.Map.find name ctx.ctx_decl.ctx_enums)))
ctrs
in
let _, ctr =
@ -760,7 +758,7 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
(translate_match_arm z3_arg)
ctx
(List.combine
(List.map snd (EnumConstructorMap.bindings cases))
(List.map snd (EnumConstructor.Map.bindings cases))
(Datatype.get_accessors z3_enum))
in
let z3_arms =
@ -873,9 +871,9 @@ module Backend = struct
ctx_decl = decl_ctx;
ctx_funcdecl = Var.Map.empty;
ctx_z3vars = StringMap.empty;
ctx_z3datatypes = EnumMap.empty;
ctx_z3datatypes = EnumName.Map.empty;
ctx_z3matchsubsts = Var.Map.empty;
ctx_z3structs = StructMap.empty;
ctx_z3structs = StructName.Map.empty;
ctx_z3unit = z3unit;
ctx_z3constraints = [];
}

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

@ -33,17 +33,15 @@ Message: unexpected token
Autosuggestion: did you mean "content", or maybe "condition"?
Error token:
┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.20-25
┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.20-25:
└──┐
│
11 │ context my_gaming scope GamingAuthorized
│ ‾‾‾‾‾
Last good token:
┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.10-19
┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.10-19:
└──┐
│
11 │ context my_gaming scope GamingAuthorized
│ ‾‾‾‾‾‾‾‾‾
@ -79,17 +77,15 @@ Message: unexpected token
Autosuggestion: did you mean "content", or maybe "condition"?
Error token:
┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.20-25
┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.20-25:
└──┐
│
11 │ context my_gaming scope GamingAuthorized
│ ‾‾‾‾‾
Last good token:
┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.10-19
┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.10-19:
└──┐
│
11 │ context my_gaming scope GamingAuthorized
│ ‾‾‾‾‾‾‾‾‾
@ -125,17 +121,15 @@ Message: unexpected token
Autosuggestion: did you mean "content", or maybe "condition"?
Error token:
┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.20-25
┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.20-25:
└──┐
│
11 │ context my_gaming scope GamingAuthorized
│ ‾‾‾‾‾
Last good token:
┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.10-19
┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.10-19:
└──┐
│
11 │ context my_gaming scope GamingAuthorized
│ ‾‾‾‾‾‾‾‾‾
@ -173,17 +167,15 @@ Message: unexpected token
Autosuggestion: did you mean "content", or maybe "condition"?
Error token:
┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.20-25
┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.20-25:
└──┐
│
11 │ context my_gaming scope GamingAuthorized
│ ‾‾‾‾‾
Last good token:
┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.10-19
┌─⯈ examples/NSW_community_gaming/tests/test_nsw_social_housie.catala_en:11.10-19:
└──┐
│
11 │ context my_gaming scope GamingAuthorized
│ ‾‾‾‾‾‾‾‾‾

30
examples/aides_logement/code_construction_legislatif.catala_fr
View File

@ -640,9 +640,9 @@ champ d'application ÉligibilitéAidePersonnaliséeLogement:
règle condition_logement_bailleur sous condition
selon ménage.logement.mode_occupation sous forme
-- Locataire de location:
(selon location.Location.bailleur sous forme
(selon location.bailleur sous forme
-- BailleurSocial de convention:
convention.ConventionBailleurSocial.
convention.
conventionné_livre_III_titre_V_chap_III
-- BailleurPrivéAvecConventionnementSocial de convention:
convention.conventionné_livre_III_titre_II_chap_I_sec_3
@ -683,7 +683,7 @@ champ d'application ÉligibilitéAidePersonnaliséeLogement:
règle condition_logement_bailleur sous condition
selon ménage.logement.mode_occupation sous forme
-- RésidentLogementFoyer de location:
location.LogementFoyer.conventionné_livre_III_titre_V_chap_III
location.conventionné_livre_III_titre_V_chap_III
-- n'importe quel: faux
conséquence rempli
```
@ -891,19 +891,19 @@ champ d'application ÉligibilitéAllocationLogement:
-- AutrePersonneÀCharge: faux
-- EnfantÀCharge de enfant: (prestations_familiales.droit_ouvert de
EnfantPrestationsFamiliales {
-- identifiant: enfant.EnfantÀCharge.identifiant
-- obligation_scolaire: enfant.EnfantÀCharge.obligation_scolaire
-- rémuneration_mensuelle: enfant.EnfantÀCharge.rémuneration_mensuelle
-- date_de_naissance: enfant.EnfantÀCharge.date_de_naissance
-- identifiant: enfant.identifiant
-- obligation_scolaire: enfant.obligation_scolaire
-- rémuneration_mensuelle: enfant.rémuneration_mensuelle
-- date_de_naissance: enfant.date_de_naissance
-- prise_en_charge: (selon enfant.situation_garde_alternée sous forme
-- GardeAlternéeCoefficientPriseEnCharge:
PriseEnChargeEnfant.GardeAlternéePartageAllocations
-- PasDeGardeAlternée:
PriseEnChargeEnfant.EffectiveEtPermanente)
-- a_déjà_ouvert_droit_aux_allocations_familiales:
enfant.EnfantÀCharge.a_déjà_ouvert_droit_aux_allocations_familiales
enfant.a_déjà_ouvert_droit_aux_allocations_familiales
-- bénéficie_titre_personnel_aide_personnelle_logement:
enfant.EnfantÀCharge.
enfant.
bénéficie_titre_personnel_aide_personnelle_logement
}
)
@ -923,19 +923,19 @@ champ d'application ÉligibilitéAllocationLogement:
-- AutrePersonneÀCharge: faux
-- EnfantÀCharge de enfant: non (prestations_familiales.droit_ouvert de
EnfantPrestationsFamiliales {
-- identifiant: enfant.EnfantÀCharge.identifiant
-- obligation_scolaire: enfant.EnfantÀCharge.obligation_scolaire
-- rémuneration_mensuelle: enfant.EnfantÀCharge.rémuneration_mensuelle
-- date_de_naissance: enfant.EnfantÀCharge.date_de_naissance
-- identifiant: enfant.identifiant
-- obligation_scolaire: enfant.obligation_scolaire
-- rémuneration_mensuelle: enfant.rémuneration_mensuelle
-- date_de_naissance: enfant.date_de_naissance
-- prise_en_charge: (selon enfant.situation_garde_alternée sous forme
-- GardeAlternéeCoefficientPriseEnCharge:
PriseEnChargeEnfant.GardeAlternéePartageAllocations
-- PasDeGardeAlternée:
PriseEnChargeEnfant.EffectiveEtPermanente)
-- a_déjà_ouvert_droit_aux_allocations_familiales:
enfant.EnfantÀCharge.a_déjà_ouvert_droit_aux_allocations_familiales
enfant.a_déjà_ouvert_droit_aux_allocations_familiales
-- bénéficie_titre_personnel_aide_personnelle_logement:
enfant.EnfantÀCharge.
enfant.
bénéficie_titre_personnel_aide_personnelle_logement
}
)

74
examples/aides_logement/code_construction_reglementaire.catala_fr
View File

@ -128,7 +128,7 @@ champ d'application RessourcesAidesPersonnelleLogement:
définition ressources_personnes_vivant_habituellement_foyer égal à
somme argent pour personne dans personnes_vivant_habituellement_foyer de
personne.PersonneVivantHabituellementAuFoyer.ressources
personne.ressources
```
Sont considérées comme vivant habituellement au foyer les personnes y ayant
@ -1137,7 +1137,7 @@ champ d'application ÉligibilitéAidesPersonnelleLogement:
règle prise_en_compte_personne_à_charge de personne_à_charge sous condition
selon personne_à_charge sous forme
-- EnfantÀCharge de enfant:
enfant.EnfantÀCharge.date_de_naissance +@ 21 an >@ date_courante
enfant.date_de_naissance +@ 21 an >@ date_courante
-- AutrePersonneÀCharge de parent: faux
conséquence rempli
```
@ -1163,16 +1163,16 @@ champ d'application ÉligibilitéAidesPersonnelleLogement:
-- EnfantÀCharge de enfant: faux
-- AutrePersonneÀCharge de parent:
parent.parenté = Ascendant et
parent.AutrePersonneÀCharge.ressources <=€
parent.ressources <=€
plafond_individuel_l815_9_sécu *€ 1,25 et
(
(parent.AutrePersonneÀCharge.date_naissance +@
(parent.date_naissance +@
âge_l351_8_1_sécu <=@ date_courante ou
(parent.titulaire_allocation_personne_âgée et
parent.AutrePersonneÀCharge.date_naissance +@ 65 an <=@
parent.date_naissance +@ 65 an <=@
date_courante)
) ou
(parent.AutrePersonneÀCharge.date_naissance +@
(parent.date_naissance +@
âge_l161_17_2_sécu <=@ date_courante et
parent.bénéficiaire_l161_19_l351_8_l643_3_sécu)
)
@ -1204,7 +1204,7 @@ champ d'application ÉligibilitéAidesPersonnelleLogement:
-- AutrePersonneÀCharge de parent:
# Pas besoin de préciser parenté car inclusif ici
parent.incapacité_80_pourcent_ou_restriction_emploi et
parent.AutrePersonneÀCharge.ressources <=€
parent.ressources <=€
plafond_individuel_l815_9_sécu *€ 1,25
conséquence rempli
```
@ -1393,7 +1393,7 @@ champ d'application CalculAllocationLogement:
AccessionPropriété contenu propriétaire
définition aide_finale_formule égal à
sous_calcul_traitement.Traitement_formule_aide_finale.aide_finale_formule
sous_calcul_traitement.aide_finale_formule
définition traitement_aide_finale de arg égal à
(sous_calcul_traitement.
Traitement_formule_aide_finale.traitement_aide_finale de arg)
@ -1411,7 +1411,7 @@ champ d'application CalculAidePersonnaliséeLogement:
AccessionPropriété contenu propriétaire
définition aide_finale_formule égal à
sous_calcul_traitement.Traitement_formule_aide_finale.aide_finale_formule
sous_calcul_traitement.aide_finale_formule
définition traitement_aide_finale de arg égal à
(sous_calcul_traitement.
Traitement_formule_aide_finale.traitement_aide_finale de arg)
@ -1441,7 +1441,7 @@ champ d'application CalculAidePersonnaliséeLogement:
location.âgées_ou_handicap_adultes_hébergées_onéreux_particuliers
-- type_aide: type_aide
-- réduction_loyer_solidarité:
(selon location.Location.bailleur sous forme
(selon location.bailleur sous forme
-- BailleurSocial de bailleur:
bailleur.réduction_loyer_solidarité_perçue
-- n'importe quel: 0€)
@ -1525,7 +1525,7 @@ champ d'application CalculAllocationLogement:
location.âgées_ou_handicap_adultes_hébergées_onéreux_particuliers
-- type_aide: type_aide
-- réduction_loyer_solidarité:
(selon location.Location.bailleur sous forme
(selon location.bailleur sous forme
-- BailleurSocial de bailleur:
bailleur.réduction_loyer_solidarité_perçue
-- n'importe quel: 0€)
@ -1534,7 +1534,7 @@ champ d'application CalculAllocationLogement:
}
dans Traitement_formule_aide_finale {
-- aide_finale_formule:
traitement_formule.CalculAllocationLogementLocatif.aide_finale_formule
traitement_formule.aide_finale_formule
-- traitement_aide_finale:
traitement_formule.
CalculAllocationLogementLocatif.
@ -1557,7 +1557,7 @@ champ d'application CalculAllocationLogement:
location.âgées_ou_handicap_adultes_hébergées_onéreux_particuliers
-- type_aide: type_aide
-- réduction_loyer_solidarité:
(selon location.Location.bailleur sous forme
(selon location.bailleur sous forme
-- BailleurSocial de bailleur:
bailleur.réduction_loyer_solidarité_perçue
-- n'importe quel: 0€)
@ -1588,7 +1588,7 @@ champ d'application CalculAllocationLogement:
}
dans Traitement_formule_aide_finale {
-- aide_finale_formule:
traitement_formule.CalculAllocationLogementFoyer.aide_finale_formule
traitement_formule.aide_finale_formule
-- traitement_aide_finale:
traitement_formule.
CalculAllocationLogementFoyer.traitement_aide_finale
@ -2973,8 +2973,8 @@ par l'article D. 331-64.
champ d'application ÉligibilitéAidePersonnaliséeLogement:
règle caractéristiques_prêt_l831_1_1 de prêt sous condition
prêt.titulaire_prêt sous forme Demandeur et (
prêt.Prêt.type_prêt sous forme D331_32 ou
prêt.Prêt.type_prêt sous forme D331_63_64)
prêt.type_prêt sous forme D331_32 ou
prêt.type_prêt sous forme D331_63_64)
conséquence rempli
```
@ -3009,8 +3009,8 @@ champ d'application ÉligibilitéAidePersonnaliséeLogement:
règle caractéristiques_prêt_l831_1_1 de prêt sous condition
prêt.titulaire_prêt sous forme
VendeurQuandDemandeurAContratLocationAccession et (
prêt.Prêt.type_prêt sous forme D331_59_8 ou
prêt.Prêt.type_prêt sous forme D331_76_1)
prêt.type_prêt sous forme D331_59_8 ou
prêt.type_prêt sous forme D331_76_1)
conséquence rempli
```
@ -4027,14 +4027,14 @@ champ d'application CalculÉquivalenceLoyerMinimale:
définition tranches_revenus_d832_26_multipliées égal à
application pour tranche dans tranches_revenus_d832_26 de
TrancheRevenuDécimal {
-- haut: (selon tranche.TrancheRevenu.haut sous forme
-- haut: (selon tranche.haut sous forme
-- LimiteTranche.Infini: LimiteTrancheDécimal.Infini
-- LimiteTranche.Revenu de tranche_haut:
LimiteTrancheDécimal.Revenu contenu
((argent_vers_décimal de tranche_haut) *. n_nombre_parts_d832_25))
-- bas: argent_vers_décimal de tranche.TrancheRevenu.bas *.
-- bas: argent_vers_décimal de tranche.bas *.
n_nombre_parts_d832_25
-- taux: tranche.TrancheRevenu.taux
-- taux: tranche.taux
}
définition montant égal à
@ -4044,23 +4044,23 @@ champ d'application CalculÉquivalenceLoyerMinimale:
décimal_vers_argent de (
(((somme décimal pour tranche dans tranches_revenus_d832_26_multipliées de
(si
ressources_ménage_arrondies <=. tranche.TrancheRevenuDécimal.bas
ressources_ménage_arrondies <=. tranche.bas
alors 0,0
sinon
(selon tranche.TrancheRevenuDécimal.haut sous forme
(selon tranche.haut sous forme
-- LimiteTrancheDécimal.Revenu de tranche_haut:
(si
ressources_ménage_arrondies >=. tranche_haut
alors
(tranche_haut -. tranche.TrancheRevenuDécimal.bas) *.
tranche.TrancheRevenuDécimal.taux
(tranche_haut -. tranche.bas) *.
tranche.taux
sinon
((ressources_ménage_arrondies -.
tranche.TrancheRevenuDécimal.bas) *.
tranche.TrancheRevenuDécimal.taux))
tranche.bas) *.
tranche.taux))
-- LimiteTrancheDécimal.Infini:
(ressources_ménage_arrondies -. tranche.TrancheRevenuDécimal.bas) *.
tranche.TrancheRevenuDécimal.taux)
(ressources_ménage_arrondies -. tranche.bas) *.
tranche.taux)
))) +.
argent_vers_décimal de montant_forfaitaire_d832_26 *.
n_nombre_parts_d832_25) /. 12,0)
@ -4083,23 +4083,23 @@ champ d'application CalculÉquivalenceLoyerMinimale:
décimal_vers_argent de (
(((somme décimal pour tranche dans tranches_revenus_d832_26_multipliées de
(si
ressources_ménage_arrondies <=. tranche.TrancheRevenuDécimal.bas
ressources_ménage_arrondies <=. tranche.bas
alors 0,0
sinon
(selon tranche.TrancheRevenuDécimal.haut sous forme
(selon tranche.haut sous forme
-- LimiteTrancheDécimal.Revenu de tranche_haut:
(si
ressources_ménage_arrondies >=. tranche_haut
alors
(tranche_haut -. tranche.TrancheRevenuDécimal.bas) *.
tranche.TrancheRevenuDécimal.taux
(tranche_haut -. tranche.bas) *.
tranche.taux
sinon
((ressources_ménage_arrondies -.
tranche.TrancheRevenuDécimal.bas) *.
tranche.TrancheRevenuDécimal.taux))
tranche.bas) *.
tranche.taux))
-- LimiteTrancheDécimal.Infini:
(ressources_ménage_arrondies -. tranche.TrancheRevenuDécimal.bas) *.
tranche.TrancheRevenuDécimal.taux)
(ressources_ménage_arrondies -. tranche.bas) *.
tranche.taux)
))) +.
argent_vers_décimal de montant_forfaitaire_d832_26) /. 12,0)
```

2
examples/aides_logement/code_sécurité_sociale.catala_fr
View File

@ -121,7 +121,7 @@ champ d'application OuvertureDroitsRetraite:
champ d'application ÉligibilitéAidesPersonnelleLogement:
définition ouverture_droits_retraite.date_naissance_assuré égal à
demandeur.Demandeur.date_naissance
demandeur.date_naissance
définition âge_l161_17_2_sécu égal à
ouverture_droits_retraite.âge_ouverture_droit
```

18
examples/prestations_familiales/sécurité_sociale_L.catala_fr
View File

@ -53,8 +53,8 @@ ouvre droit aux prestations familiales :
```catala
champ d'application ÉligibilitéPrestationsFamiliales :
étiquette cas_base règle droit_ouvert de enfant sous condition
enfant.EnfantPrestationsFamiliales.obligation_scolaire sous forme Avant ou
enfant.EnfantPrestationsFamiliales.obligation_scolaire sous forme Pendant
enfant.obligation_scolaire sous forme Avant ou
enfant.obligation_scolaire sous forme Pendant
conséquence rempli
```
@ -64,20 +64,20 @@ dont la rémunération éventuelle n'excède pas un plafond.
```catala
champ d'application ÉligibilitéPrestationsFamiliales :
étiquette cas_base règle droit_ouvert de enfant sous condition
enfant.EnfantPrestationsFamiliales.obligation_scolaire sous forme Après et
(enfant.EnfantPrestationsFamiliales.rémuneration_mensuelle <=€
enfant.obligation_scolaire sous forme Après et
(enfant.rémuneration_mensuelle <=€
plafond_l512_3_2) et
(enfant.EnfantPrestationsFamiliales.date_de_naissance +@ âge_l512_3_2 >@
(enfant.date_de_naissance +@ âge_l512_3_2 >@
date_courante)
conséquence rempli
# On définit les conditions hors âge d'abord car elles
# sont référencées plus tard dans l'article L521-1
règle conditions_hors_âge de enfant sous condition
enfant.EnfantPrestationsFamiliales.obligation_scolaire sous forme Avant ou
enfant.EnfantPrestationsFamiliales.obligation_scolaire sous forme Pendant ou
enfant.EnfantPrestationsFamiliales.obligation_scolaire sous forme Après et
(enfant.EnfantPrestationsFamiliales.rémuneration_mensuelle <=€
enfant.obligation_scolaire sous forme Avant ou
enfant.obligation_scolaire sous forme Pendant ou
enfant.obligation_scolaire sous forme Après et
(enfant.rémuneration_mensuelle <=€
plafond_l512_3_2)
conséquence rempli
```

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