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

Reformat

Browse Source
This commit is contained in:
Louis Gesbert 2023-08-16 00:04:45 +02:00
parent c58e76f4e5
commit 72882f82df
43 changed files with 974 additions and 880 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
build_system/clerk_driver.ml
View File

@ -173,7 +173,6 @@ let readdir_sort (dirname : string) : string array =
dirs
with Sys_error _ -> [||]
(** Given a file, looks in the relative [output] directory if there are files
with the same base name that contain expected outputs for different *)
let search_for_expected_outputs (file : string) : expected_output_descr list =

12
build_system/clerk_runtest.ml
View File

@ -40,7 +40,7 @@ let checkfile parents file =
~pp_sep:(fun ppf () -> Format.fprintf ppf " %a@ " String.format "→")
Format.pp_print_string)
(List.rev (file :: parents));
(file :: parents), file
file :: parents, file
let with_in_channel_safe parents file f =
try File.with_in_channel file f
@ -186,9 +186,9 @@ let run_inline_tests
| [] -> Message.emit_warning "No inline tests found in %s" file
| file_tests ->
Message.emit_debug "@[<v 2>Running tests:@ %a@]"
(Format.pp_print_list
(fun ppf t -> Format.fprintf ppf "- @[<hov>%s:@ %d tests@]"
t.filename (List.length t.tests)))
(Format.pp_print_list (fun ppf t ->
Format.fprintf ppf "- @[<hov>%s:@ %d tests@]" t.filename
(List.length t.tests)))
file_tests;
let run test oc =
List.iter
@ -214,7 +214,8 @@ let run_inline_tests
let pid =
let cwd = Unix.getcwd () in
Unix.chdir file_dir;
Fun.protect ~finally:(fun () -> Unix.chdir cwd) @@ fun () ->
Fun.protect ~finally:(fun () -> Unix.chdir cwd)
@@ fun () ->
Unix.create_process_env catala_exe cmd env Unix.stdin cmd_out_wr
cmd_out_wr
in
@ -256,4 +257,3 @@ let run_inline_tests
Sys.rename out test.filename)
else run test stdout)
file_tests

14
build_system/clerk_runtest.mli
View File

@ -14,10 +14,18 @@
License for the specific language governing permissions and limitations under
the License. *)
(** This module contains specific commands used to detect and run inline tests in Catala files. The functionality is built into the `clerk runtest` subcommand, but is separate from the normal Clerk behaviour: Clerk drives Ninja, which in turn might need to evaluate tests as part of some rules and can run `clerk runtest` in a reentrant way. *)
(** This module contains specific commands used to detect and run inline tests
in Catala files. The functionality is built into the `clerk runtest`
subcommand, but is separate from the normal Clerk behaviour: Clerk drives
Ninja, which in turn might need to evaluate tests as part of some rules and
can run `clerk runtest` in a reentrant way. *)
val has_inline_tests : string -> bool
(** Checks if the given named file contains inline tests (either directly or through includes) *)
(** Checks if the given named file contains inline tests (either directly or
through includes) *)
val run_inline_tests : reset:bool -> string -> string -> string list -> unit
(** [run_inline_tests ~reset file catala_exe catala_opts] runs the tests in Catala [file] using the given path to the Catala executable and the provided options. Output is printed to [stdout] if [reset] is false, otherwise [file] is replaced with the updated test results. *)
(** [run_inline_tests ~reset file catala_exe catala_opts] runs the tests in
Catala [file] using the given path to the Catala executable and the provided
options. Output is printed to [stdout] if [reset] is false, otherwise [file]
is replaced with the updated test results. *)

9
compiler/catala_utils/map.ml
View File

@ -33,7 +33,6 @@ module type S = sig
(* Slightly more informative [Not_found] exception *)
val find : key -> 'a t -> 'a
val keys : 'a t -> key list
val values : 'a t -> 'a list
val of_list : (key * 'a) list -> 'a t
@ -70,7 +69,6 @@ module type S = sig
unit
(** Formats all bindings of the map in order using the given separator
(default ["; "]) and binding indicator (default [" = "]). *)
end
module Make (Ord : OrderedType) : S with type key = Ord.t = struct
@ -79,14 +77,13 @@ module Make (Ord : OrderedType) : S with type key = Ord.t = struct
exception Not_found of key
let () =
Printexc.register_printer @@ function
Printexc.register_printer
@@ function
| Not_found k ->
Some (Format.asprintf "key '%a' not found in map" Ord.format k)
| _ -> None
let find k t =
try find k t with Stdlib.Not_found -> raise (Not_found k)
let find k t = try find k t with Stdlib.Not_found -> raise (Not_found k)
let keys t = fold (fun k _ acc -> k :: acc) t [] |> List.rev
let values t = fold (fun _ v acc -> v :: acc) t [] |> List.rev
let of_list l = List.fold_left (fun m (k, v) -> add k v m) empty l

193
compiler/dcalc/from_scopelang.ml
View File

@ -35,7 +35,8 @@ type 'm scope_ref =
type 'm scope_sig_ctx = {
scope_sig_local_vars : scope_var_ctx list; (** List of scope variables *)
scope_sig_scope_ref : 'm scope_ref; (** Var or external representing the scope *)
scope_sig_scope_ref : 'm scope_ref;
(** Var or external representing the scope *)
scope_sig_input_struct : StructName.t; (** Scope input *)
scope_sig_output_struct : StructName.t; (** Scope output *)
scope_sig_in_fields : scope_input_var_ctx ScopeVar.Map.t;
@ -75,11 +76,12 @@ let pos_mark_mk (type a m) (e : (a, m) gexpr) :
let rec module_scope_sig scope_sig_ctx path scope =
match path with
| [] -> ScopeName.Map.find scope scope_sig_ctx.scope_sigs
| (modname, mpos) :: path ->
| (modname, mpos) :: path -> (
match ModuleName.Map.find_opt modname scope_sig_ctx.scope_sigs_modules with
| None ->
Message.raise_spanned_error mpos "Module %a not found" ModuleName.format modname
| Some sig_ctx -> module_scope_sig sig_ctx path scope
Message.raise_spanned_error mpos "Module %a not found" ModuleName.format
modname
| Some sig_ctx -> module_scope_sig sig_ctx path scope)
let merge_defaults
~(is_func : bool)
@ -223,7 +225,8 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
Message.raise_spanned_error (Expr.pos e)
"The constructor %a of enum %a%a is missing from this pattern \
matching"
EnumConstructor.format constructor Print.path path EnumName.format name
EnumConstructor.format constructor Print.path path
EnumName.format name
in
let case_d = translate_expr ctx case_e in
( EnumConstructor.Map.add constructor case_d d_cases,
@ -234,8 +237,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
if not (EnumConstructor.Map.is_empty remaining_e_cases) then
Message.raise_spanned_error (Expr.pos e)
"Pattern matching is incomplete for enum %a%a: missing cases %a"
Print.path path
EnumName.format name
Print.path path EnumName.format name
(EnumConstructor.Map.format_keys ~pp_sep:(fun fmt () ->
Format.fprintf fmt ", "))
remaining_e_cases;
@ -243,9 +245,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
Expr.ematch ~e:e1 ~name ~cases:d_cases m
| EScopeCall { path; scope; args } ->
let pos = Expr.mark_pos m in
let sc_sig =
module_scope_sig ctx.scopes_parameters path scope
in
let sc_sig = module_scope_sig ctx.scopes_parameters path scope in
let in_var_map =
ScopeVar.Map.merge
(fun var_name (str_field : scope_input_var_ctx option) expr ->
@ -292,18 +292,20 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
in_var_map StructField.Map.empty
in
let arg_struct =
Expr.estruct ~name:sc_sig.scope_sig_input_struct ~fields:field_map (mark_tany m pos)
Expr.estruct ~name:sc_sig.scope_sig_input_struct ~fields:field_map
(mark_tany m pos)
in
let called_func =
let m = mark_tany m pos in
let e = match sc_sig.scope_sig_scope_ref with
let e =
match sc_sig.scope_sig_scope_ref with
| Local_scope_ref v -> Expr.evar v m
| External_scope_ref (path, name) ->
Expr.eexternal ~path ~name:(Mark.map (fun s -> External_scope s) name) m
Expr.eexternal ~path
~name:(Mark.map (fun s -> External_scope s) name)
m
in
tag_with_log_entry
e
BeginCall
tag_with_log_entry e BeginCall
[ScopeName.get_info scope; Mark.add (Expr.pos e) "direct"]
in
let single_arg =
@ -351,14 +353,17 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
(struct_output.struct_output_function_field x) ... } *)
let result_eta_expanded =
Expr.estruct ~name:sc_sig.scope_sig_output_struct
~fields:(StructField.Map.mapi
~fields:
(StructField.Map.mapi
(fun field typ ->
let original_field_expr =
Expr.estructaccess
~e:(Expr.make_var result_var
~e:
(Expr.make_var result_var
(Expr.with_ty m
(TStruct sc_sig.scope_sig_output_struct, Expr.pos e)))
~field ~name:sc_sig.scope_sig_output_struct (Expr.with_ty m typ)
~field ~name:sc_sig.scope_sig_output_struct
(Expr.with_ty m typ)
in
match Mark.remove typ with
| TArrow (ts_in, t_out) ->
@ -382,7 +387,8 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
(ListLabels.mapi (List.combine params_vars ts_in)
~f:(fun i (param_var, t_in) ->
tag_with_log_entry
(Expr.make_var param_var (Expr.with_ty m t_in))
(Expr.make_var param_var
(Expr.with_ty m t_in))
(VarDef
{
log_typ = Mark.remove t_in;
@ -405,7 +411,9 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
EndCall f_markings)
ts_in (Expr.pos e)
| _ -> original_field_expr)
(snd (StructName.Map.find sc_sig.scope_sig_output_struct ctx.decl_ctx.ctx_structs)))
(snd
(StructName.Map.find sc_sig.scope_sig_output_struct
ctx.decl_ctx.ctx_structs)))
(Expr.with_ty m (TStruct sc_sig.scope_sig_output_struct, Expr.pos e))
in
(* Here we have to go through an if statement that records a decision being
@ -457,9 +465,9 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
match ctx.scope_name, Mark.remove f with
| Some sname, ELocation loc -> (
match loc with
| ScopelangScopeVar { name = (v, _); _ } ->
| ScopelangScopeVar { name = v, _; _ } ->
[ScopeName.get_info sname; ScopeVar.get_info v]
| SubScopeVar {scope; var = (v, _); _} ->
| SubScopeVar { scope; var = v, _; _ } ->
[ScopeName.get_info scope; ScopeVar.get_info v]
| ToplevelVar _ -> [])
| _ -> []
@ -572,9 +580,9 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
| EOp { op = Add_dat_dur _; tys } ->
Expr.eop (Add_dat_dur ctx.date_rounding) tys m
| EOp { op; tys } -> Expr.eop (Operator.translate op) tys m
| ( EVar _ | EAbs _ | ELit _ | EStruct _ | EStructAccess _
| ETuple _ | ETupleAccess _ | EInj _ | EEmptyError | EErrorOnEmpty _
| EArray _ | EIfThenElse _ ) as e ->
| ( EVar _ | EAbs _ | ELit _ | EStruct _ | EStructAccess _ | ETuple _
| ETupleAccess _ | EInj _ | EEmptyError | EErrorOnEmpty _ | EArray _
| EIfThenElse _ ) as e ->
Expr.map ~f:(translate_expr ctx) (e, m)
(** The result of a rule translation is a list of assignment, with variables and
@ -781,9 +789,7 @@ let translate_rule
all_subscope_output_vars
in
let subscope_func =
tag_with_log_entry
scope_dcalc_ref
BeginCall
tag_with_log_entry scope_dcalc_ref BeginCall
[
sigma_name, pos_sigma;
SubScopeName.get_info subindex;
@ -896,15 +902,16 @@ let translate_rules
((fun next -> next), ctx)
rules
in
let scope_sig_decl =
ScopeName.Map.find scope_name ctx.decl_ctx.ctx_scopes
in
let scope_sig_decl = ScopeName.Map.find scope_name ctx.decl_ctx.ctx_scopes in
let return_exp =
Expr.estruct ~name:scope_sig.scope_sig_output_struct
~fields:(ScopeVar.Map.fold
~fields:
(ScopeVar.Map.fold
(fun var (dcalc_var, _, io) acc ->
if Mark.remove io.Desugared.Ast.io_output then
let field = ScopeVar.Map.find var scope_sig_decl.out_struct_fields in
let field =
ScopeVar.Map.find var scope_sig_decl.out_struct_fields
in
StructField.Map.add field
(Expr.make_var dcalc_var (mark_tany mark pos_sigma))
acc
@ -918,7 +925,8 @@ let translate_rules
(Expr.Box.lift return_exp)),
new_ctx )
(* From a scope declaration and definitions, create the corresponding scope body wrapped in the appropriate call convention. *)
(* From a scope declaration and definitions, create the corresponding scope body
wrapped in the appropriate call convention. *)
let translate_scope_decl
(ctx : 'm ctx)
(scope_name : ScopeName.t)
@ -972,14 +980,16 @@ let translate_scope_decl
(* Find a witness of a mark in the definitions *)
match sigma.scope_decl_rules with
| [] ->
(* Todo: are we sure this can't happen in normal code ? E.g. is calling a scope which only defines input variables already an error at this stage or not ? *)
Message.raise_spanned_error pos_sigma "Scope %a has no content" ScopeName.format scope_name
(* Todo: are we sure this can't happen in normal code ? E.g. is calling a
scope which only defines input variables already an error at this stage
or not ? *)
Message.raise_spanned_error pos_sigma "Scope %a has no content"
ScopeName.format scope_name
| (Definition (_, _, _, (_, m)) | Assertion (_, m) | Call (_, _, m)) :: _ ->
m
in
let rules_with_return_expr, ctx =
translate_rules ctx scope_name sigma.scope_decl_rules sigma_info
scope_mark
translate_rules ctx scope_name sigma.scope_decl_rules sigma_info scope_mark
scope_sig
in
let scope_variables =
@ -1034,8 +1044,7 @@ let translate_scope_decl
})
(Bindlib.bind_var v next)
(Expr.Box.lift
(Expr.make_var scope_input_var
(mark_tany scope_mark pos_sigma))))
(Expr.make_var scope_input_var (mark_tany scope_mark pos_sigma))))
scope_input_variables next
in
let scope_body =
@ -1062,8 +1071,7 @@ let translate_scope_decl
let new_struct_ctx =
StructName.Map.singleton scope_input_struct_name ([], field_map)
in
( scope_body,
new_struct_ctx )
scope_body, new_struct_ctx
let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
let defs_dependencies = Scopelang.Dependency.build_program_dep_graph prgm in
@ -1073,28 +1081,42 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
in
let decl_ctx = prgm.program_ctx in
Message.emit_debug "prog scopes: %a@ modules: %a"
(ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space) prgm.program_scopes
(ModuleName.Map.format
(fun fmt prg -> ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space fmt prg.Scopelang.Ast.program_scopes)) prgm.program_modules;
(ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space)
prgm.program_scopes
(ModuleName.Map.format (fun fmt prg ->
ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space fmt
prg.Scopelang.Ast.program_scopes))
prgm.program_modules;
let sctx : 'm scope_sigs_ctx =
let process_scope_sig (scope_path, scope_name) scope =
Message.emit_debug "process_scope_sig %a%a (%a)"
Print.path scope_path ScopeName.format scope_name ScopeName.format scope.Scopelang.Ast.scope_decl_name;
Message.emit_debug "process_scope_sig %a%a (%a)" Print.path scope_path
ScopeName.format scope_name ScopeName.format
scope.Scopelang.Ast.scope_decl_name;
let scope_ref =
match scope_path with
| [] ->
let v = Var.make (Mark.remove (ScopeName.get_info scope_name)) in
Local_scope_ref v
| path ->
External_scope_ref (path, Mark.copy (ScopeName.get_info scope_name) scope_name)
External_scope_ref
(path, Mark.copy (ScopeName.get_info scope_name) scope_name)
in
let scope_info =
try
ScopeName.Map.find scope_name (Program.module_ctx decl_ctx scope_path).ctx_scopes
with ScopeName.Map.Not_found _ -> Message.raise_spanned_error (Mark.get (ScopeName.get_info scope_name)) "Could not find scope %a%a" Print.path scope_path ScopeName.format scope_name
ScopeName.Map.find scope_name
(Program.module_ctx decl_ctx scope_path).ctx_scopes
with ScopeName.Map.Not_found _ ->
Message.raise_spanned_error
(Mark.get (ScopeName.get_info scope_name))
"Could not find scope %a%a" Print.path scope_path ScopeName.format
scope_name
in
let scope_sig_in_fields =
(* Output fields have already been generated and added to the program ctx at this point, because they are visible to the user (manipulated as the return type of ScopeCalls) ; but input fields are used purely internally and need to be created here to implement the call convention for scopes. *)
(* Output fields have already been generated and added to the program
ctx at this point, because they are visible to the user (manipulated
as the return type of ScopeCalls) ; but input fields are used purely
internally and need to be created here to implement the call
convention for scopes. *)
ScopeVar.Map.filter_map
(fun dvar (typ, vis) ->
match Mark.remove vis.Desugared.Ast.io_input with
@ -1127,48 +1149,64 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
}
in
let rec process_modules path prg =
{ scope_sigs =
{
scope_sigs =
ScopeName.Map.mapi
(fun scope_name (scope_decl, _) ->
process_scope_sig (path, scope_name) scope_decl)
prg.Scopelang.Ast.program_scopes;
scope_sigs_modules =
ModuleName.Map.mapi (fun modname prg ->
ModuleName.Map.mapi
(fun modname prg ->
process_modules (path @ [modname, Pos.no_pos]) prg)
prg.Scopelang.Ast.program_modules;
}
in
{ scope_sigs =
{
scope_sigs =
ScopeName.Map.mapi
(fun scope_name (scope_decl, _) ->
process_scope_sig ([], scope_name) scope_decl)
prgm.Scopelang.Ast.program_scopes;
scope_sigs_modules =
ModuleName.Map.mapi (fun modname prg ->
process_modules [modname, Pos.no_pos] prg)
ModuleName.Map.mapi
(fun modname prg -> process_modules [modname, Pos.no_pos] prg)
prgm.Scopelang.Ast.program_modules;
}
in
let rec gather_module_in_structs acc path sctx =
(* Expose all added in_structs from submodules at toplevel *)
ModuleName.Map.fold (fun modname scope_sigs acc ->
ModuleName.Map.fold
(fun modname scope_sigs acc ->
let path = path @ [modname, Pos.no_pos] in
let acc = gather_module_in_structs acc path scope_sigs.scope_sigs_modules in
ScopeName.Map.fold (fun _ scope_sig_ctx acc ->
let acc =
gather_module_in_structs acc path scope_sigs.scope_sigs_modules
in
ScopeName.Map.fold
(fun _ scope_sig_ctx acc ->
let fields =
ScopeVar.Map.fold (fun _ sivc acc ->
let pos = Mark.get (StructField.get_info sivc.scope_input_name) in
StructField.Map.add sivc.scope_input_name (sivc.scope_input_typ, pos) acc)
ScopeVar.Map.fold
(fun _ sivc acc ->
let pos =
Mark.get (StructField.get_info sivc.scope_input_name)
in
StructField.Map.add sivc.scope_input_name
(sivc.scope_input_typ, pos)
acc)
scope_sig_ctx.scope_sig_in_fields StructField.Map.empty
in
StructName.Map.add scope_sig_ctx.scope_sig_input_struct
(path, fields) acc)
scope_sigs.scope_sigs acc
)
sctx
acc
scope_sigs.scope_sigs acc)
sctx acc
in
let decl_ctx =
{
decl_ctx with
ctx_structs =
gather_module_in_structs decl_ctx.ctx_structs [] sctx.scope_sigs_modules;
}
in
let decl_ctx = { decl_ctx with ctx_structs = gather_module_in_structs decl_ctx.ctx_structs [] sctx.scope_sigs_modules } in
let top_ctx =
let toplevel_vars =
TopdefName.Map.mapi
@ -1208,19 +1246,23 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
translate_scope_decl ctx scope_name (Mark.remove scope)
in
let scope_var =
match (ScopeName.Map.find scope_name sctx.scope_sigs).scope_sig_scope_ref with
match
(ScopeName.Map.find scope_name sctx.scope_sigs)
.scope_sig_scope_ref
with
| Local_scope_ref v -> v
| External_scope_ref _ -> assert false
in
( {
ctx with
decl_ctx =
{ ctx.decl_ctx with
{
ctx.decl_ctx with
ctx_structs =
StructName.Map.union
(fun _ _ -> assert false)
ctx.decl_ctx.ctx_structs scope_in_struct;
}
};
},
scope_var,
Bindlib.box_apply
@ -1235,8 +1277,7 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
ctx )
in
let items, ctx = translate_defs top_ctx defs_ordering in
(* WIP TODO FIXME HERE: the scopes in submodules are not translated here it seems, and their input structs not added to decl_ctx (see From_surface:1476 for decl_ctx flattening info) *)
{
code_items = Bindlib.unbox items;
decl_ctx = ctx.decl_ctx;
}
(* WIP TODO FIXME HERE: the scopes in submodules are not translated here it
seems, and their input structs not added to decl_ctx (see From_surface:1476
for decl_ctx flattening info) *)
{ code_items = Bindlib.unbox items; decl_ctx = ctx.decl_ctx }

3
compiler/desugared/ast.ml
View File

@ -248,7 +248,8 @@ let free_variables (def : rule RuleName.Map.t) : Pos.t ScopeDef.Map.t =
(fun (loc, loc_pos) acc ->
let usage =
match loc with
| DesugaredScopeVar { name; state } -> Some (ScopeDef.Var (Mark.remove name, state))
| DesugaredScopeVar { name; state } ->
Some (ScopeDef.Var (Mark.remove name, state))
| SubScopeVar { alias; var; _ } ->
Some
(ScopeDef.SubScopeVar

3
compiler/desugared/dependency.ml
View File

@ -261,7 +261,8 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
(fun used_var g ->
let edge_from =
match Mark.remove used_var with
| DesugaredScopeVar { name; state } -> Some (Vertex.Var (Mark.remove name, state))
| DesugaredScopeVar { name; state } ->
Some (Vertex.Var (Mark.remove name, state))
| SubScopeVar { alias; _ } ->
Some (Vertex.SubScope (Mark.remove alias))
| ToplevelVar _ -> None

12
compiler/desugared/disambiguate.ml
View File

@ -86,16 +86,16 @@ let program prg =
env
in
let rec build_typing_env prg =
ModuleName.Map.fold (fun modname prg ->
ModuleName.Map.fold
(fun modname prg ->
Typing.Env.add_module modname ~module_env:(build_typing_env prg))
prg.program_modules
(base_typing_env prg)
prg.program_modules (base_typing_env prg)
in
let env =
ModuleName.Map.fold (fun modname prg ->
ModuleName.Map.fold
(fun modname prg ->
Typing.Env.add_module modname ~module_env:(build_typing_env prg))
prg.program_modules
(base_typing_env prg)
prg.program_modules (base_typing_env prg)
in
let program_topdefs =
TopdefName.Map.map

200
compiler/desugared/from_surface.ml
View File

@ -168,13 +168,16 @@ let rec disambiguate_constructor
with EnumName.Map.Not_found _ ->
Message.raise_spanned_error pos "Enum %s does not contain case %s"
(Mark.remove enum) (Mark.remove constructor))
| (modname, mpos)::path ->
| (modname, mpos) :: path -> (
match ModuleName.Map.find_opt modname ctxt.modules with
| None ->
Message.raise_spanned_error mpos "Module %a not found" ModuleName.format modname
Message.raise_spanned_error mpos "Module %a not found" ModuleName.format
modname
| Some ctxt ->
let constructor = List.map (Mark.map (fun (_, c) -> path, c)) constructor0 in
disambiguate_constructor ctxt constructor pos
let constructor =
List.map (Mark.map (fun (_, c) -> path, c)) constructor0
in
disambiguate_constructor ctxt constructor pos)
let int100 = Runtime.integer_of_int 100
let rat100 = Runtime.decimal_of_integer int100
@ -240,14 +243,14 @@ let rec translate_expr
[tau] pos
else
let binding_var = Var.make (Mark.remove binding) in
let local_vars = Ident.Map.add (Mark.remove binding) binding_var local_vars in
let local_vars =
Ident.Map.add (Mark.remove binding) binding_var local_vars
in
let e2 = rec_helper ~local_vars e2 in
Expr.make_abs [| binding_var |] e2 [tau] pos)
(EnumName.Map.find enum_uid ctxt.enums)
in
Expr.ematch
~e:(rec_helper e1_sub)
~name:enum_uid ~cases emark
Expr.ematch ~e:(rec_helper e1_sub) ~name:enum_uid ~cases emark
| Binop ((((S.And | S.Or | S.Xor), _) as op), e1, e2) ->
check_formula op e1;
check_formula op e2;
@ -349,7 +352,8 @@ let rec translate_expr
with respect to the state that we are defining. *)
let rec find_prev_state = function
| [] -> None
| st0 :: st1 :: _ when StateName.equal inside_def_state st1 ->
| st0 :: st1 :: _ when StateName.equal inside_def_state st1
->
Some st0
| _ :: states -> find_prev_state states
in
@ -358,7 +362,9 @@ let rec translate_expr
(* we take the last state in the chain *)
Some (List.hd (List.rev states)))
in
Expr.elocation (DesugaredScopeVar { name = uid, pos; state = x_state }) emark
Expr.elocation
(DesugaredScopeVar { name = uid, pos; state = x_state })
emark
| Some (SubScope _)
(* Note: allowing access to a global variable with the same name as a
subscope is disputable, but I see no good reason to forbid it either *)
@ -366,21 +372,21 @@ let rec translate_expr
match Ident.Map.find_opt x ctxt.topdefs with
| Some v ->
Expr.elocation
(ToplevelVar { path = []; name = v, Mark.get (TopdefName.get_info v) })
(ToplevelVar
{ path = []; name = v, Mark.get (TopdefName.get_info v) })
emark
| None ->
Name_resolution.raise_unknown_identifier
"for a local, scope-wide or global variable" (x, pos))))
| Ident (path, name) ->
| Ident (path, name) -> (
let ctxt = Name_resolution.module_ctx ctxt path in
(match Ident.Map.find_opt (Mark.remove name) ctxt.topdefs with
match Ident.Map.find_opt (Mark.remove name) ctxt.topdefs with
| Some v ->
Expr.elocation
(ToplevelVar { path; name = v, Mark.get (TopdefName.get_info v) })
emark
| None ->
Name_resolution.raise_unknown_identifier
"for an external variable" name)
Name_resolution.raise_unknown_identifier "for an external variable" name)
| Dotted (e, ((path, x), _ppos)) -> (
match path, Mark.remove e with
| [], Ident ([], (y, _))
@ -397,11 +403,12 @@ let rec translate_expr
Name_resolution.get_var_uid subscope_real_uid ctxt x
in
Expr.elocation
(SubScopeVar {
(SubScopeVar
{
path = subscope_path;
scope = subscope_real_uid;
alias = (subscope_uid, pos);
var = (subscope_var_uid, pos)
alias = subscope_uid, pos;
var = subscope_var_uid, pos;
})
emark
| _ ->
@ -409,17 +416,16 @@ let rec translate_expr
let e = rec_helper e in
let rec get_str ctxt = function
| [] -> None
| [c] ->
Some (Name_resolution.get_struct ctxt c)
| (modname, mpos) :: path ->
| [c] -> Some (Name_resolution.get_struct ctxt c)
| (modname, mpos) :: path -> (
match ModuleName.Map.find_opt modname ctxt.modules with
| None ->
Message.raise_spanned_error mpos
"Module %a not found" ModuleName.format modname
| Some ctxt ->
get_str ctxt path
Message.raise_spanned_error mpos "Module %a not found"
ModuleName.format modname
| Some ctxt -> get_str ctxt path)
in
Expr.edstructaccess ~e ~field:(Mark.remove x) ~name_opt:(get_str ctxt path) ~path emark)
Expr.edstructaccess ~e ~field:(Mark.remove x)
~name_opt:(get_str ctxt path) ~path emark)
| FunCall (f, args) ->
Expr.eapp (rec_helper f) (List.map rec_helper args) emark
| ScopeCall (((path, id), _), fields) ->
@ -467,11 +473,7 @@ let rec translate_expr
let local_vars = Ident.Map.add (Mark.remove x) v local_vars in
let tau = TAny, Mark.get x in
(* This type will be resolved in Scopelang.Desambiguation *)
let fn =
Expr.make_abs [| v |]
(rec_helper ~local_vars e2)
[tau] pos
in
let fn = Expr.make_abs [| v |] (rec_helper ~local_vars e2) [tau] pos in
Expr.eapp fn [rec_helper e1] emark
| StructLit ((([], s_name), _), fields) ->
let s_uid =
@ -540,12 +542,14 @@ let rec translate_expr
let e_uid, c_uid = EnumName.Map.choose possible_c_uids in
let payload = Option.map rec_helper payload in
Expr.einj
~e:(match payload with
~e:
(match payload with
| Some e' -> e'
| None -> Expr.elit LUnit mark_constructor)
~cons:c_uid ~name:e_uid emark
| path_enum -> (
let path, enum = match List.rev path_enum with
let path, enum =
match List.rev path_enum with
| enum :: rpath -> List.rev rpath, enum
| _ -> assert false
in
@ -555,11 +559,10 @@ let rec translate_expr
let e_uid = Name_resolution.get_enum ctxt enum in
try
let c_uid = EnumName.Map.find e_uid possible_c_uids in
let payload =
Option.map rec_helper payload
in
let payload = Option.map rec_helper payload in
Expr.einj
~e:(match payload with
~e:
(match payload with
| Some e' -> e'
| None -> Expr.elit LUnit mark_constructor)
~cons:c_uid ~name:e_uid emark
@ -570,8 +573,7 @@ let rec translate_expr
let e1 = rec_helper e1 in
let cases_d, e_uid =
disambiguate_match_and_build_expression scope inside_definition_of ctxt
local_vars
cases
local_vars cases
in
Expr.ematch ~e:e1 ~name:e_uid ~cases:cases_d emark
| TestMatchCase (e1, pattern) ->
@ -594,9 +596,7 @@ let rec translate_expr
[tau] pos)
(EnumName.Map.find enum_uid ctxt.enums)
in
Expr.ematch
~e:(rec_helper e1)
~name:enum_uid ~cases:cases emark
Expr.ematch ~e:(rec_helper e1) ~name:enum_uid ~cases emark
| ArrayLit es -> Expr.earray (List.map rec_helper es) emark
| CollectionOp (((S.Filter { f } | S.Map { f }) as op), collection) ->
let collection = rec_helper collection in
@ -619,8 +619,8 @@ let rec translate_expr
emark)
[f_pred; collection] emark
| CollectionOp
(S.AggregateArgExtremum { max; default; f = param_name, predicate }, collection)
->
( S.AggregateArgExtremum { max; default; f = param_name, predicate },
collection ) ->
let default = rec_helper default in
let pos_dft = Expr.pos default in
let collection = rec_helper collection in
@ -800,9 +800,7 @@ and disambiguate_match_and_build_expression
let bind_match_cases (cases_d, e_uid, curr_index) (case, case_pos) =
match case with
| S.MatchCase case ->
let constructor, binding =
Mark.remove case.S.match_case_pattern
in
let constructor, binding = Mark.remove case.S.match_case_pattern in
let e_uid', c_uid =
disambiguate_constructor ctxt constructor
(Mark.get case.S.match_case_pattern)
@ -826,7 +824,9 @@ and disambiguate_match_and_build_expression
[None, Mark.get case.match_case_expr; None, Expr.pos e_case]
"The constructor %a has been matched twice:" EnumConstructor.format
c_uid);
let local_vars, param_var = create_var local_vars (Option.map Mark.remove binding) in
let local_vars, param_var =
create_var local_vars (Option.map Mark.remove binding)
in
let case_body =
translate_expr scope inside_definition_of ctxt local_vars
case.S.match_case_expr
@ -882,7 +882,8 @@ and disambiguate_match_and_build_expression
(* Creates the wildcard payload *)
let local_vars, payload_var = create_var local_vars None in
let case_body =
translate_expr scope inside_definition_of ctxt local_vars match_case_expr
translate_expr scope inside_definition_of ctxt local_vars
match_case_expr
in
let e_binder = Expr.bind [| payload_var |] case_body in
@ -972,8 +973,7 @@ let process_rule_parameters
Message.raise_multispanned_error
[
Some "Arguments declared here", pos;
( Some "Definition missing the arguments",
Mark.get def.S.definition_name );
Some "Definition missing the arguments", Mark.get def.S.definition_name;
]
"This definition for %a is missing the arguments" Ast.ScopeDef.format
decl_name
@ -1005,7 +1005,8 @@ let process_default
(cons : S.expression) : Ast.rule =
let just =
match just with
| Some just -> Some (translate_expr (Some scope) (Some def_key) ctxt local_vars just)
| Some just ->
Some (translate_expr (Some scope) (Some def_key) ctxt local_vars just)
| None -> None
in
let just = merge_conditions precond just (Mark.get def_key) in
@ -1159,7 +1160,9 @@ let process_scope_use_item
(ctxt : Name_resolution.context)
(prgm : Ast.program)
(item : S.scope_use_item Mark.pos) : Ast.program =
let precond = Option.map (translate_expr (Some scope) None ctxt Ident.Map.empty) precond in
let precond =
Option.map (translate_expr (Some scope) None ctxt Ident.Map.empty) precond
in
match Mark.remove item with
| S.Rule rule -> process_rule precond scope ctxt prgm rule
| S.Definition def -> process_def precond scope ctxt prgm def
@ -1277,7 +1280,8 @@ let process_topdef
let expr_opt =
match def.S.topdef_expr, def.S.topdef_args with
| None, _ -> None
| Some e, None -> Some (Expr.unbox_closed (translate_expr None None ctxt Ident.Map.empty e))
| Some e, None ->
Some (Expr.unbox_closed (translate_expr None None ctxt Ident.Map.empty e))
| Some e, Some (args, _) ->
let local_vars, args_tys =
List.fold_left_map
@ -1417,9 +1421,8 @@ let init_scope_defs
Ident.Map.fold add_def scope_idmap Ast.ScopeDef.Map.empty
(** Main function of this module *)
let translate_program
(ctxt : Name_resolution.context)
(surface : S.program) : Ast.program =
let translate_program (ctxt : Name_resolution.context) (surface : S.program) :
Ast.program =
let desugared =
let get_program_scopes ctxt =
ScopeName.Map.mapi
@ -1430,7 +1433,9 @@ let translate_program
match v with
| Name_resolution.SubScope _ -> acc
| Name_resolution.ScopeVar v -> (
let v_sig = ScopeVar.Map.find v ctxt.Name_resolution.var_typs in
let v_sig =
ScopeVar.Map.find v ctxt.Name_resolution.var_typs
in
match v_sig.Name_resolution.var_sig_states_list with
| [] -> ScopeVar.Map.add v Ast.WholeVar acc
| states -> ScopeVar.Map.add v (Ast.States states) acc))
@ -1458,28 +1463,40 @@ let translate_program
in
let rec make_ctx ctxt =
let submodules =
ModuleName.Map.map make_ctx ctxt.Name_resolution.modules;
ModuleName.Map.map make_ctx ctxt.Name_resolution.modules
in
{
Ast.program_ctx =
{
(* After name resolution, type definitions (structs and enums) are exposed at toplevel for easier lookup, but their paths need to remain available for printing and later passes *)
(* After name resolution, type definitions (structs and enums) are
exposed at toplevel for easier lookup, but their paths need to
remain available for printing and later passes *)
ctx_structs =
ModuleName.Map.fold (fun modname prg acc ->
StructName.Map.union (fun _ _ _ -> assert false) acc
ModuleName.Map.fold
(fun modname prg acc ->
StructName.Map.union
(fun _ _ _ -> assert false)
acc
(StructName.Map.map
(fun (path, def) -> (modname, Pos.no_pos) :: path, def)
prg.Ast.program_ctx.ctx_structs))
submodules
(StructName.Map.map (fun def -> [], def) ctxt.Name_resolution.structs);
(StructName.Map.map
(fun def -> [], def)
ctxt.Name_resolution.structs);
ctx_enums =
ModuleName.Map.fold (fun modname prg acc ->
EnumName.Map.union (fun _ _ _ -> assert false) acc
ModuleName.Map.fold
(fun modname prg acc ->
EnumName.Map.union
(fun _ _ _ -> assert false)
acc
(EnumName.Map.map
(fun (path, def) -> (modname, Pos.no_pos) :: path, def)
prg.Ast.program_ctx.ctx_enums))
submodules
(EnumName.Map.map (fun def -> [], def) ctxt.Name_resolution.enums);
(EnumName.Map.map
(fun def -> [], def)
ctxt.Name_resolution.enums);
ctx_scopes =
Ident.Map.fold
(fun _ def acc ->
@ -1490,7 +1507,8 @@ let translate_program
ctxt.Name_resolution.typedefs ScopeName.Map.empty;
ctx_struct_fields = ctxt.Name_resolution.field_idmap;
ctx_topdefs = ctxt.Name_resolution.topdef_types;
ctx_modules = ModuleName.Map.map (fun s -> s.Ast.program_ctx) submodules;
ctx_modules =
ModuleName.Map.map (fun s -> s.Ast.program_ctx) submodules;
};
Ast.program_topdefs = TopdefName.Map.empty;
Ast.program_scopes = get_program_scopes ctxt;
@ -1505,41 +1523,49 @@ let translate_program
match Mark.remove item with
| S.ScopeUse use -> process_scope_use ctxt prgm use
| S.Topdef def -> process_topdef ctxt prgm def
| S.ScopeDecl _ | S.StructDecl _
| S.EnumDecl _ ->
prgm)
| S.ScopeDecl _ | S.StructDecl _ | S.EnumDecl _ -> prgm)
prgm block
in
let rec process_structure
(prgm : Ast.program)
(item : S.law_structure) : Ast.program =
let rec process_structure (prgm : Ast.program) (item : S.law_structure) :
Ast.program =
match item with
| S.LawHeading (_, children) ->
List.fold_left
(fun prgm child -> process_structure prgm child)
prgm children
| S.CodeBlock (block, _, _) ->
process_code_block ctxt prgm block
| S.CodeBlock (block, _, _) -> process_code_block ctxt prgm block
| S.LawInclude _ | S.LawText _ -> prgm
in
Message.emit_debug "DESUGARED → prog scopes: %a@ modules: %a"
(ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space) desugared.Ast.program_scopes
(ModuleName.Map.format
(fun fmt prg -> ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space fmt prg.Ast.program_scopes)) desugared.Ast.program_modules;
(ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space)
desugared.Ast.program_scopes
(ModuleName.Map.format (fun fmt prg ->
ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space fmt
prg.Ast.program_scopes))
desugared.Ast.program_modules;
let desugared =
List.fold_left (fun acc (id, intf) ->
List.fold_left
(fun acc (id, intf) ->
let modul = ModuleName.Map.find id acc.Ast.program_modules in
let modul = process_code_block (Name_resolution.module_ctx ctxt [id, Pos.no_pos]) modul intf in
{ acc with program_modules =
ModuleName.Map.add id modul acc.program_modules })
desugared
surface.S.program_modules
let modul =
process_code_block
(Name_resolution.module_ctx ctxt [id, Pos.no_pos])
modul intf
in
{
acc with
program_modules = ModuleName.Map.add id modul acc.program_modules;
})
desugared surface.S.program_modules
in
let desugared =
List.fold_left process_structure desugared surface.S.program_items
in
Message.emit_debug "DESUGARED2 → prog scopes: %a@ modules: %a"
(ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space) desugared.Ast.program_scopes
(ModuleName.Map.format
(fun fmt prg -> ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space fmt prg.Ast.program_scopes)) desugared.Ast.program_modules;
(ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space)
desugared.Ast.program_scopes
(ModuleName.Map.format (fun fmt prg ->
ScopeName.Map.format_keys ~pp_sep:Format.pp_print_space fmt
prg.Ast.program_scopes))
desugared.Ast.program_modules;
desugared

3
compiler/desugared/linting.ml
View File

@ -108,7 +108,8 @@ let detect_unused_struct_fields (p : program) : unit =
~f:(fun struct_fields_used e ->
let rec structs_fields_used_expr e struct_fields_used =
match Mark.remove e with
| EDStructAccess { name_opt = Some name; e = e_struct; field; path = _ } ->
| EDStructAccess
{ name_opt = Some name; e = e_struct; field; path = _ } ->
let field =
StructName.Map.find name
(Ident.Map.find field p.program_ctx.ctx_struct_fields)

74
compiler/desugared/name_resolution.ml
View File

@ -65,8 +65,7 @@ type var_sig = {
type typedef =
| TStruct of StructName.t
| TEnum of EnumName.t
| TScope of ScopeName.t * scope_info
(** Implicitly defined output struct *)
| TScope of ScopeName.t * scope_info (** Implicitly defined output struct *)
type context = {
typedefs : typedef Ident.Map.t;
@ -238,15 +237,15 @@ let get_scope ctxt id =
Message.raise_spanned_error (Mark.get id) "No scope named %s found"
(Mark.remove id)
let rec module_ctx ctxt path = match path with
let rec module_ctx ctxt path =
match path with
| [] -> ctxt
| (modname, mpos) :: path ->
(match ModuleName.Map.find_opt modname ctxt.modules with
| (modname, mpos) :: path -> (
match ModuleName.Map.find_opt modname ctxt.modules with
| None ->
Message.raise_spanned_error mpos
"Module %a not found" ModuleName.format modname
| Some ctxt ->
module_ctx ctxt path)
Message.raise_spanned_error mpos "Module %a not found" ModuleName.format
modname
| Some ctxt -> module_ctx ctxt path)
(** {1 Declarations pass} *)
@ -267,8 +266,7 @@ let process_subscope_decl
in
Message.raise_multispanned_error
[Some "first use", Mark.get info; Some "second use", s_pos]
"Subscope name @{<yellow>\"%s\"@} already used"
(Mark.remove subscope)
"Subscope name @{<yellow>\"%s\"@} already used" (Mark.remove subscope)
| None ->
let sub_scope_uid = SubScopeName.fresh (name, name_pos) in
let original_subscope_uid =
@ -316,23 +314,24 @@ let rec process_base_typ
| Surface.Ast.Text -> raise_unsupported_feature "text type" typ_pos
| Surface.Ast.Named ([], (ident, _pos)) -> (
match Ident.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 (TStruct s_uid) -> TStruct s_uid, typ_pos
| Some (TEnum e_uid) -> TEnum e_uid, typ_pos
| Some (TScope (_, scope_str)) ->
TStruct ( scope_str.out_struct_name), typ_pos
TStruct scope_str.out_struct_name, typ_pos
| None ->
Message.raise_spanned_error typ_pos
"Unknown type @{<yellow>\"%s\"@}, not a struct or enum previously \
declared"
ident)
| Surface.Ast.Named ((modul, mpos)::path, id) ->
| Surface.Ast.Named ((modul, mpos) :: path, id) -> (
match ModuleName.Map.find_opt modul ctxt.modules with
| None ->
Message.raise_spanned_error mpos
"This refers to module %a, which was not found"
ModuleName.format modul
"This refers to module %a, which was not found" ModuleName.format
modul
| Some mod_ctxt ->
process_base_typ mod_ctxt Surface.Ast.(Data (Primitive (Named (path, id))), typ_pos))
process_base_typ mod_ctxt
Surface.Ast.(Data (Primitive (Named (path, id))), typ_pos)))
(** Process a type (function or not) *)
let process_type (ctxt : context) ((naked_typ, typ_pos) : Surface.Ast.typ) : typ
@ -589,7 +588,9 @@ let process_scope_decl (ctxt : context) (decl : Surface.Ast.scope_decl) :
(Mark.remove decl.scope_decl_name)
(function
| Some (TScope (scope, { in_struct_name; out_struct_name; _ })) ->
Some (TScope (scope, { in_struct_name; out_struct_name; out_struct_fields; }))
Some
(TScope
(scope, { in_struct_name; out_struct_name; out_struct_fields }))
| _ -> assert false)
ctxt.typedefs
in
@ -681,9 +682,14 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
"toplevel definition")
(Ident.Map.find_opt name ctxt.topdefs);
let uid = TopdefName.fresh def.topdef_name in
{ ctxt with
{
ctxt with
topdefs = Ident.Map.add name uid ctxt.topdefs;
topdef_types = TopdefName.Map.add uid (process_type ctxt def.topdef_type) ctxt.topdef_types }
topdef_types =
TopdefName.Map.add uid
(process_type ctxt def.topdef_type)
ctxt.topdef_types;
}
(** Process a code item that is a declaration *)
let process_decl_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
@ -699,16 +705,14 @@ let process_decl_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
let process_code_block
(process_item : context -> Surface.Ast.code_item Mark.pos -> context)
(ctxt : context)
(block : Surface.Ast.code_block) :
context =
(block : Surface.Ast.code_block) : context =
List.fold_left (fun ctxt decl -> process_item ctxt decl) ctxt block
(** Process a law structure, only considering the code blocks *)
let rec process_law_structure
(process_item : context -> Surface.Ast.code_item Mark.pos -> context)
(ctxt : context)
(s : Surface.Ast.law_structure) :
context =
(s : Surface.Ast.law_structure) : context =
match s with
| Surface.Ast.LawHeading (_, children) ->
List.fold_left
@ -758,7 +762,8 @@ let get_def_key
ScopeVar.format x_uid
else None )
| [y; x] ->
let (subscope_uid, (path, subscope_real_uid)) : SubScopeName.t * (path * ScopeName.t) =
let (subscope_uid, (path, subscope_real_uid))
: SubScopeName.t * (path * ScopeName.t) =
match Ident.Map.find_opt (Mark.remove y) scope_ctxt.var_idmap with
| Some (SubScope (v, u)) -> v, u
| Some _ ->
@ -933,14 +938,11 @@ let empty_ctxt =
let import_module modules (name, intf) =
let ctxt = { empty_ctxt with modules } in
let ctxt =
List.fold_left process_name_item ctxt intf
in
let ctxt =
List.fold_left process_decl_item ctxt intf
in
let ctxt = List.fold_left process_name_item ctxt intf in
let ctxt = List.fold_left process_decl_item ctxt intf in
let ctxt = { ctxt with modules = empty_ctxt.modules } in
(* No submodules at the moment, a module may use the ones loaded before it, but doesn't reexport them *)
(* No submodules at the moment, a module may use the ones loaded before it,
but doesn't reexport them *)
ModuleName.Map.add name ctxt modules
(** Derive the context from metadata, in one pass over the declarations *)
@ -950,8 +952,10 @@ let form_context (prgm : Surface.Ast.program) : context =
in
let ctxt = { empty_ctxt with modules } in
let rec gather_var_sigs acc modules =
(* Scope vars from imported modules need to be accessible directly for definitions through submodules *)
ModuleName.Map.fold (fun _modname mctx acc ->
(* Scope vars from imported modules need to be accessible directly for
definitions through submodules *)
ModuleName.Map.fold
(fun _modname mctx acc ->
let acc = gather_var_sigs acc mctx.modules in
ScopeVar.Map.union (fun _ _ -> assert false) acc mctx.var_typs)
modules acc

6
compiler/desugared/name_resolution.mli
View File

@ -65,8 +65,7 @@ type var_sig = {
type typedef =
| TStruct of StructName.t
| TEnum of EnumName.t
| TScope of ScopeName.t * scope_info
(** Implicitly defined output struct *)
| TScope of ScopeName.t * scope_info (** Implicitly defined output struct *)
type context = {
typedefs : typedef Ident.Map.t;
@ -152,7 +151,8 @@ val get_scope : context -> Ident.t Mark.pos -> ScopeName.t
has a different kind *)
val module_ctx : context -> path -> context
(** Returns the context corresponding to the given module path; raises a user error if the module is not found *)
(** Returns the context corresponding to the given module path; raises a user
error if the module is not found *)
val process_type : context -> Surface.Ast.typ -> typ
(** Convert a surface base type to an AST type *)

8
compiler/driver.ml
View File

@ -61,9 +61,7 @@ module Passes = struct
let prg =
Surface.Parser_driver.parse_top_level_file options.input_file language
in
let prg =
Surface.Fill_positions.fill_pos_with_legislative_info prg
in
let prg = Surface.Fill_positions.fill_pos_with_legislative_info prg in
let prg =
{ prg with program_modules = load_module_interfaces options link_modules }
in
@ -256,8 +254,8 @@ module Commands = struct
"Variable @{<yellow>\"%s\"@} not found inside scope @{<yellow>\"%a\"@}"
variable ScopeName.format scope_uid
| Some
(Desugared.Name_resolution.SubScope (subscope_var_name, (subscope_path, subscope_name)))
-> (
(Desugared.Name_resolution.SubScope
(subscope_var_name, (subscope_path, subscope_name))) -> (
match second_part with
| None ->
Message.raise_error

7
compiler/lcalc/ast.ml
View File

@ -26,7 +26,8 @@ module OptionMonad = struct
Expr.einj ~e ~cons:Expr.some_constr ~name:Expr.option_enum mark
let empty ~(mark : 'a mark) =
Expr.einj ~e:(Expr.elit LUnit mark) ~cons:Expr.none_constr ~name:Expr.option_enum mark
Expr.einj ~e:(Expr.elit LUnit mark) ~cons:Expr.none_constr
~name:Expr.option_enum mark
let bind_var ~(mark : 'a mark) f x arg =
let cases =
@ -36,8 +37,8 @@ module OptionMonad = struct
let x = Var.make "_" in
Expr.eabs
(Expr.bind [| x |]
(Expr.einj ~e:(Expr.evar x mark) ~cons:Expr.none_constr ~name:Expr.option_enum
mark))
(Expr.einj ~e:(Expr.evar x mark) ~cons:Expr.none_constr
~name:Expr.option_enum mark))
[TLit TUnit, Expr.mark_pos mark]
mark );
(* | None x -> None x *)

9
compiler/lcalc/compile_without_exceptions.ml
View File

@ -169,7 +169,11 @@ let rec trans (ctx : typed ctx) (e : typed D.expr) : (lcalc, typed) boxed_gexpr
Ast.OptionMonad.return ~mark
(Expr.eapp
(Expr.evar (trans_var ctx scope) mark)
[Expr.estruct ~name ~fields:(StructField.Map.map (trans ctx) fields) mark]
[
Expr.estruct ~name
~fields:(StructField.Map.map (trans ctx) fields)
mark;
]
mark)
| EApp { f = (EVar ff, _) as f; args }
when not (Var.Map.find ff ctx.ctx_vars).is_scope ->
@ -750,8 +754,7 @@ let translate_program (prgm : typed D.program) : untyped A.program =
ctx_structs =
prgm.decl_ctx.ctx_structs
|> StructName.Map.mapi (fun _n (path, str) ->
path,
StructField.Map.map trans_typ_keep str);
path, StructField.Map.map trans_typ_keep str);
}
in

30
compiler/lcalc/to_ocaml.ml
View File

@ -218,9 +218,7 @@ let rec format_typ (fmt : Format.formatter) (typ : typ) : unit =
| TClosureEnv -> failwith "unimplemented!"
let format_var_str (fmt : Format.formatter) (v : string) : unit =
let lowercase_name =
String.to_snake_case (String.to_ascii v)
in
let lowercase_name = String.to_snake_case (String.to_ascii v) in
let lowercase_name =
Re.Pcre.substitute ~rex:(Re.Pcre.regexp "\\.")
~subst:(fun _ -> "_dot_")
@ -276,13 +274,21 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
in
match Mark.remove e with
| EVar v -> Format.fprintf fmt "%a" format_var v
| EExternal { path; name } ->
| EExternal { path; name } -> (
Print.path fmt path;
(* FIXME: this is wrong in general !!
We assume the idents exposed by the module depend only on the original name, while they actually get through Bindlib and may have been renamed. A correct implem could use the runtime registration used by the interpreter, but that would be distasteful and incur a penalty ; or we would need to reproduce the same structure as in the original module to ensure that bindlib performs the exact same renamings ; or finally we could normalise the names at generation time (either at toplevel or in a dedicated submodule ?) *)
(match Mark.remove name with
| External_value name -> format_var_str fmt (Mark.remove (TopdefName.get_info name))
| External_scope name -> format_var_str fmt (Mark.remove (ScopeName.get_info name)))
(* FIXME: this is wrong in general !! We assume the idents exposed by the
module depend only on the original name, while they actually get through
Bindlib and may have been renamed. A correct implem could use the runtime
registration used by the interpreter, but that would be distasteful and
incur a penalty ; or we would need to reproduce the same structure as in
the original module to ensure that bindlib performs the exact same
renamings ; or finally we could normalise the names at generation time
(either at toplevel or in a dedicated submodule ?) *)
match Mark.remove name with
| External_value name ->
format_var_str fmt (Mark.remove (TopdefName.get_info name))
| External_scope name ->
format_var_str fmt (Mark.remove (ScopeName.get_info name)))
| ETuple es ->
Format.fprintf fmt "@[<hov 2>(%a)@]"
(Format.pp_print_list
@ -550,12 +556,10 @@ let format_ctx
match struct_or_enum with
| Scopelang.Dependency.TVertex.Struct s ->
let path, def = StructName.Map.find s ctx.ctx_structs in
if path = [] then
Format.fprintf fmt "%a@\n" format_struct_decl (s, def)
if path = [] then Format.fprintf fmt "%a@\n" format_struct_decl (s, def)
| Scopelang.Dependency.TVertex.Enum e ->
let path, def = EnumName.Map.find e ctx.ctx_enums in
if path = [] then
Format.fprintf fmt "%a@\n" format_enum_decl (e, def))
if path = [] then Format.fprintf fmt "%a@\n" format_enum_decl (e, def))
(type_ordering @ scope_structs)
let rename_vars e =

13
compiler/plugins/api_web.ml
View File

@ -165,8 +165,8 @@ module To_jsoo = struct
format_typ_to_jsoo t2 fmt_struct_name ()
format_struct_field_name (None, struct_field)
(Format.pp_print_list (fun fmt (i, ti) ->
Format.fprintf fmt "@[<hv 2>(%a@ %a)@]"
format_typ_of_jsoo ti Format.pp_print_string i))
Format.fprintf fmt "@[<hv 2>(%a@ %a)@]" format_typ_of_jsoo
ti Format.pp_print_string i))
(List.combine args_names t1)
| _ ->
Format.fprintf fmt "@[<hov 2>val %a =@ %a %a.%a@]"
@ -190,8 +190,8 @@ module To_jsoo = struct
| _ ->
Format.fprintf fmt
"@[<hv 2>%a =@ @[<hov 2>%a@ @[<hov>%a@,##.%a@]@]@]"
format_struct_field_name (None, struct_field)
format_typ_of_jsoo struct_field_type fmt_struct_name ()
format_struct_field_name (None, struct_field) format_typ_of_jsoo
struct_field_type fmt_struct_name ()
format_struct_field_name_camel_case struct_field)
fmt
(StructField.Map.bindings struct_fields)
@ -231,8 +231,9 @@ module To_jsoo = struct
(StructField.Map.bindings struct_fields)
fmt_conv_funs ()
in
let format_enum_decl fmt (enum_name, (path, (enum_cons : typ EnumConstructor.Map.t)))
=
let format_enum_decl
fmt
(enum_name, (path, (enum_cons : typ EnumConstructor.Map.t))) =
let fmt_enum_name fmt _ = format_enum_name fmt enum_name in
let fmt_module_enum_name fmt () =
Print.path fmt path;

6
compiler/plugins/json_schema.ml
View File

@ -80,8 +80,7 @@ module To_json = struct
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n")
(fun fmt (field_name, field_type) ->
Format.fprintf fmt "@[<hov 2>\"%a%a\": {@\n%a@]@\n}"
Print.path path
Format.fprintf fmt "@[<hov 2>\"%a%a\": {@\n%a@]@\n}" Print.path path
format_struct_field_name_camel_case field_name fmt_type field_type)
fmt
(StructField.Map.bindings fields)
@ -105,7 +104,8 @@ module To_json = struct
(t :: acc) @ collect_required_type_defs_from_scope_input s
| TEnum e ->
List.fold_left collect (t :: acc)
(EnumConstructor.Map.values (snd (EnumName.Map.find e ctx.ctx_enums)))
(EnumConstructor.Map.values
(snd (EnumName.Map.find e ctx.ctx_enums)))
| TArray t -> collect acc t
| _ -> acc
in

3
compiler/plugins/lazy_interp.ml
View File

@ -234,7 +234,8 @@ let interpret_program (prg : ('dcalc, 'm) gexpr program) (scope : ScopeName.t) :
let m = Mark.get e in
let application_arg =
Expr.estruct ~name:scope_arg_struct
~fields:(StructField.Map.map
~fields:
(StructField.Map.map
(function
| TArrow (ty_in, ty_out), _ ->
Expr.make_abs

2
compiler/plugins/modules.ml
View File

@ -115,7 +115,7 @@ let compile options link_modules optimize check_invariants =
gen_ocaml options link_modules optimize check_invariants (Some modname) None
in
let flags = ["-I"; Lazy.force runtime_dir] in
let shared_out = File.(Filename.dirname ml_file / basename ^ ".cmxs") in
let shared_out = File.((Filename.dirname ml_file / basename) ^ ".cmxs") in
Message.emit_debug "Compiling OCaml shared object file @{<bold>%s@}..."
shared_out;
run_process "ocamlopt" ("-shared" :: ml_file :: "-o" :: shared_out :: flags);

12
compiler/scalc/print.ml
View File

@ -43,8 +43,8 @@ let rec format_expr
| EFunc v -> Format.fprintf fmt "%a" format_func_name v
| EStruct (es, s) ->
let path, fields = StructName.Map.find s decl_ctx.ctx_structs in
Format.fprintf fmt "@[<hov 2>%a%a@ %a%a%a@]" Print.path path StructName.format s
Print.punctuation "{"
Format.fprintf fmt "@[<hov 2>%a%a@ %a%a%a@]" Print.path path
StructName.format s Print.punctuation "{"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt (e, (struct_field, _)) ->
@ -150,13 +150,11 @@ let rec format_statement
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt ((case, _), (arm_block, payload_name)) ->
Format.fprintf fmt "%a %a%a%a@ %a @[<v 2>%a@ %a@]" Print.punctuation
"|" Print.path path Print.enum_constructor case Print.punctuation ":"
format_var_name payload_name Print.punctuation "→"
"|" Print.path path Print.enum_constructor case Print.punctuation
":" format_var_name payload_name Print.punctuation "→"
(format_block decl_ctx ~debug)
arm_block))
(List.combine
(EnumConstructor.Map.bindings cons)
arms)
(List.combine (EnumConstructor.Map.bindings cons) arms)
and format_block
(decl_ctx : decl_ctx)

10
compiler/scalc/to_python.ml
View File

@ -274,9 +274,7 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
| EVar v -> format_var fmt v
| EFunc f -> format_func_name fmt f
| EStruct (es, s) ->
let path, fields =
StructName.Map.find s ctx.ctx_structs
in
let path, fields = StructName.Map.find s ctx.ctx_structs in
Format.fprintf fmt "%a%a(%a)" Print.path path format_struct_name s
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
@ -442,9 +440,9 @@ let rec format_statement
~pp_sep:(fun fmt () -> Format.fprintf fmt "@]@\n@[<hov 4>elif ")
(fun fmt (case_block, payload_var, cons_name) ->
Format.fprintf fmt "%a.code == %a%a_Code.%a:@\n%a = %a.value@\n%a"
format_var tmp_var Print.path path format_enum_name e_name format_enum_cons_name
cons_name format_var payload_var format_var tmp_var
(format_block ctx) case_block))
format_var tmp_var Print.path path format_enum_name e_name
format_enum_cons_name cons_name format_var payload_var format_var
tmp_var (format_block ctx) case_block))
cases
| SReturn e1 ->
Format.fprintf fmt "@[<hov 4>return %a@]" (format_expression ctx)

15
compiler/scopelang/ast.ml
View File

@ -75,8 +75,7 @@ let type_program (prg : 'm program) : typed program =
let typing_env =
TopdefName.Map.fold
(fun name (_, ty) -> Typing.Env.add_toplevel_var name ty)
prg.program_topdefs
typing_env
prg.program_topdefs typing_env
in
let typing_env =
ScopeName.Map.fold
@ -88,16 +87,16 @@ let type_program (prg : 'm program) : typed program =
typing_env
in
let rec build_typing_env prg =
ModuleName.Map.fold (fun modname prg ->
ModuleName.Map.fold
(fun modname prg ->
Typing.Env.add_module modname ~module_env:(build_typing_env prg))
prg.program_modules
(base_typing_env prg)
prg.program_modules (base_typing_env prg)
in
let typing_env =
ModuleName.Map.fold (fun modname prg ->
ModuleName.Map.fold
(fun modname prg ->
Typing.Env.add_module modname ~module_env:(build_typing_env prg))
prg.program_modules
(base_typing_env prg)
prg.program_modules (base_typing_env prg)
in
let program_topdefs =
TopdefName.Map.map

4
compiler/scopelang/ast.mli
View File

@ -47,7 +47,9 @@ type 'm program = {
program_scopes : 'm scope_decl Mark.pos ScopeName.Map.t;
program_topdefs : ('m expr * typ) TopdefName.Map.t;
program_modules : nil program ModuleName.Map.t;
(* Using [nil] here ensure that program interfaces don't contain any expressions. They won't contain any rules or topdefs, but will still have the scope signatures needed to respect the call convention *)
(* Using [nil] here ensure that program interfaces don't contain any
expressions. They won't contain any rules or topdefs, but will still have
the scope signatures needed to respect the call convention *)
program_ctx : decl_ctx;
}

12
compiler/scopelang/dependency.ml
View File

@ -82,7 +82,8 @@ let rec expr_used_defs e =
e VMap.empty
in
match e with
| ELocation (ToplevelVar { path = []; name = v, pos }), _ -> VMap.singleton (Topdef v) pos
| ELocation (ToplevelVar { path = []; name = v, pos }), _ ->
VMap.singleton (Topdef v) pos
| (EScopeCall { path = []; scope; _ }, m) as e ->
VMap.add (Scope scope) (Expr.mark_pos m) (recurse_subterms e)
| EAbs { binder; _ }, _ ->
@ -148,7 +149,8 @@ let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t =
used_defs g)
g scope.Ast.scope_decl_rules)
prgm.program_scopes g
(* TODO FIXME: Add submodules here, they may still need dependency resolution type-wise (?) *)
(* TODO FIXME: Add submodules here, they may still need dependency resolution
type-wise (?) *)
let check_for_cycle_in_defs (g : SDependencies.t) : unit =
(* if there is a cycle, there will be an strongly connected component of
@ -284,8 +286,7 @@ let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t
Message.raise_spanned_error (Mark.get typ)
"The type %a%a is defined using itself, which is forbidden \
since Catala does not provide recursive types"
Print.path path
TVertex.format used
Print.path path TVertex.format used
else
let edge = TDependencies.E.create used (Mark.get typ) def in
TDependencies.add_edge_e g edge)
@ -307,8 +308,7 @@ let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t
Message.raise_spanned_error (Mark.get typ)
"The type %a%a is defined using itself, which is forbidden \
since Catala does not provide recursive types"
Print.path path
TVertex.format used
Print.path path TVertex.format used
else
let edge = TDependencies.E.create used (Mark.get typ) def in
TDependencies.add_edge_e g edge)

159
compiler/scopelang/from_desugared.ml
View File

@ -35,11 +35,12 @@ type ctx = {
let rec module_ctx ctx = function
| [] -> ctx
| (modname, mpos) :: path ->
| (modname, mpos) :: path -> (
match ModuleName.Map.find_opt modname ctx.modules with
| None ->
Message.raise_spanned_error mpos "Module %a not found" ModuleName.format modname
| Some ctx -> module_ctx ctx path
Message.raise_spanned_error mpos "Module %a not found" ModuleName.format
modname
| Some ctx -> module_ctx ctx path)
let tag_with_log_entry
(e : untyped Ast.expr boxed)
@ -51,8 +52,7 @@ let tag_with_log_entry
[e] (Mark.get e)
else e
let rec translate_expr (ctx : ctx) (e : D.expr) :
untyped Ast.expr boxed =
let rec translate_expr (ctx : ctx) (e : D.expr) : untyped Ast.expr boxed =
let m = Mark.get e in
match Mark.remove e with
| EVar v -> Expr.evar (Var.Map.find v ctx.var_mapping) m
@ -79,20 +79,26 @@ let rec translate_expr (ctx : ctx) (e : D.expr) :
| ELocation (DesugaredScopeVar { name; state = None }) ->
Expr.elocation
(ScopelangScopeVar
{ name =
match ScopeVar.Map.find (Mark.remove name) ctx.scope_var_mapping
{
name =
(match
ScopeVar.Map.find (Mark.remove name) ctx.scope_var_mapping
with
| WholeVar new_s_var -> Mark.copy name new_s_var
| States _ -> failwith "should not happen" } )
| States _ -> failwith "should not happen");
})
m
| ELocation (DesugaredScopeVar { name; state = Some state }) ->
Expr.elocation
(ScopelangScopeVar
{ name =
match ScopeVar.Map.find (Mark.remove name) ctx.scope_var_mapping
{
name =
(match
ScopeVar.Map.find (Mark.remove name) ctx.scope_var_mapping
with
| WholeVar _ -> failwith "should not happen"
| States states -> Mark.copy name (List.assoc state states) })
| States states -> Mark.copy name (List.assoc state states));
})
m
| ELocation (ToplevelVar v) -> Expr.elocation (ToplevelVar v) m
| EDStructAccess { name_opt = None; _ } ->
@ -117,14 +123,15 @@ let rec translate_expr (ctx : ctx) (e : D.expr) :
Expr.estructaccess ~e:e' ~field ~name m
| EScopeCall { path; scope; args } ->
Expr.escopecall ~path ~scope
~args:(ScopeVar.Map.fold
~args:
(ScopeVar.Map.fold
(fun v e args' ->
let v' =
match ScopeVar.Map.find v ctx.scope_var_mapping with
| WholeVar v' -> v'
| States ((_, v') :: _) ->
(* When there are multiple states, the input is always the first
one *)
(* When there are multiple states, the input is always the
first one *)
v'
| States [] -> assert false
in
@ -173,9 +180,7 @@ let def_to_exception_graph
let rule_to_exception_graph (scope : D.scope) = function
| Desugared.Dependency.Vertex.Var (var, state) -> (
let scope_def =
D.ScopeDef.Map.find
(D.ScopeDef.Var (var, state))
scope.scope_defs
D.ScopeDef.Map.find (D.ScopeDef.Var (var, state)) scope.scope_defs
in
let var_def = scope_def.D.scope_def_rules in
match Mark.remove scope_def.D.scope_def_io.io_input with
@ -195,9 +200,7 @@ let rule_to_exception_graph (scope : D.scope) = function
| _ ->
D.ScopeDef.Map.singleton
(D.ScopeDef.Var (var, state))
(def_to_exception_graph
(D.ScopeDef.Var (var, state))
var_def))
(def_to_exception_graph (D.ScopeDef.Var (var, state)) var_def))
| Desugared.Dependency.Vertex.SubScope sub_scope_index ->
(* Before calling the sub_scope, we need to include all the re-definitions
of subscope parameters*)
@ -211,9 +214,7 @@ let rule_to_exception_graph (scope : D.scope) = function
(* We exclude subscope variables that have 0 re-definitions and are
not visible in the input of the subscope *)
&& not
((match
Mark.remove scope_def.D.scope_def_io.io_input
with
((match Mark.remove scope_def.D.scope_def_io.io_input with
| NoInput -> true
| _ -> false)
&& RuleName.Map.is_empty scope_def.scope_def_rules))
@ -230,9 +231,7 @@ let rule_to_exception_graph (scope : D.scope) = function
(* This definition redefines a variable of the correct subscope. But
we have to check that this redefinition is allowed with respect
to the io parameters of that subscope variable. *)
(match
Mark.remove scope_def.D.scope_def_io.io_input
with
(match Mark.remove scope_def.D.scope_def_io.io_input with
| NoInput ->
Message.raise_multispanned_error
(( Some "Incriminated subscope:",
@ -266,13 +265,11 @@ let rule_to_exception_graph (scope : D.scope) = function
List.fold_left
(fun exc_graphs (new_exc_graph, subscope_var, var_pos) ->
D.ScopeDef.Map.add
(D.ScopeDef.SubScopeVar
(sub_scope_index, subscope_var, var_pos))
(D.ScopeDef.SubScopeVar (sub_scope_index, subscope_var, var_pos))
new_exc_graph exc_graphs)
D.ScopeDef.Map.empty
(D.ScopeDef.Map.values sub_scope_vars_redefs)
| Assertion _ ->
D.ScopeDef.Map.empty (* no exceptions for assertions *)
| Assertion _ -> D.ScopeDef.Map.empty (* no exceptions for assertions *)
let scope_to_exception_graphs (scope : D.scope) :
Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t =
@ -351,9 +348,7 @@ let rec rule_tree_to_expr
(* because each rule has its own variables parameters and we want to convert
the whole rule tree into a function, we need to perform some alpha-renaming
of all the expressions *)
let substitute_parameter
(e : D.expr boxed)
(rule : D.rule) : D.expr boxed =
let substitute_parameter (e : D.expr boxed) (rule : D.rule) : D.expr boxed =
match params, rule.D.rule_parameter with
| Some new_params, Some (old_params_with_types, _) ->
let old_params, _ = List.split old_params_with_types in
@ -390,14 +385,10 @@ let rec rule_tree_to_expr
ctx)
in
let base_just_list =
List.map
(fun rule -> substitute_parameter rule.D.rule_just rule)
base_rules
List.map (fun rule -> substitute_parameter rule.D.rule_just rule) base_rules
in
let base_cons_list =
List.map
(fun rule -> substitute_parameter rule.D.rule_cons rule)
base_rules
List.map (fun rule -> substitute_parameter rule.D.rule_cons rule) base_rules
in
let translate_and_unbox_list (list : D.expr boxed list) :
untyped Ast.expr boxed list =
@ -473,24 +464,17 @@ let translate_def
(* Here, we have to transform this list of rules into a default tree. *)
let top_list = def_map_to_tree def exc_graph in
let is_input =
match Mark.remove io.D.io_input with
| OnlyInput -> true
| _ -> false
match Mark.remove io.D.io_input with OnlyInput -> true | _ -> false
in
let is_reentrant =
match Mark.remove io.D.io_input with
| Reentrant -> true
| _ -> false
match Mark.remove io.D.io_input with Reentrant -> true | _ -> false
in
let top_value : D.rule option =
if is_cond && ((not is_subscope_var) || (is_subscope_var && is_input)) then
(* We add the bottom [false] value for conditions, only for the scope
where the condition is declared. Except when the variable is an input,
where we want the [false] to be added at each caller parent scope. *)
Some
(D.always_false_rule
(D.ScopeDef.get_position def_info)
params)
Some (D.always_false_rule (D.ScopeDef.get_position def_info) params)
else None
in
if
@ -550,20 +534,16 @@ let translate_def
exceptions to the default value *)
Node (top_list, [top_value])
| [top_tree], None -> top_tree
| _, None ->
Node (top_list, [D.empty_rule (Mark.get typ) params]))
| _, None -> Node (top_list, [D.empty_rule (Mark.get typ) params]))
let translate_rule
ctx
(scope : D.scope)
(exc_graphs :
Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t)
= function
Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t) = function
| Desugared.Dependency.Vertex.Var (var, state) -> (
let scope_def =
D.ScopeDef.Map.find
(D.ScopeDef.Var (var, state))
scope.scope_defs
D.ScopeDef.Map.find (D.ScopeDef.Var (var, state)) scope.scope_defs
in
let var_def = scope_def.D.scope_def_rules in
let var_params = scope_def.D.scope_def_parameters in
@ -613,9 +593,7 @@ let translate_rule
(* We exclude subscope variables that have 0 re-definitions and are
not visible in the input of the subscope *)
&& not
((match
Mark.remove scope_def.D.scope_def_io.io_input
with
((match Mark.remove scope_def.D.scope_def_io.io_input with
| NoInput -> true
| _ -> false)
&& RuleName.Map.is_empty scope_def.scope_def_rules))
@ -633,9 +611,7 @@ let translate_rule
(* This definition redefines a variable of the correct subscope. But
we have to check that this redefinition is allowed with respect
to the io parameters of that subscope variable. *)
(match
Mark.remove scope_def.D.scope_def_io.io_input
with
(match Mark.remove scope_def.D.scope_def_io.io_input with
| NoInput -> assert false (* error already raised *)
| OnlyInput when RuleName.Map.is_empty def && not is_cond ->
assert false (* error already raised *)
@ -652,28 +628,28 @@ let translate_rule
SubScopeName.Map.find sub_scope_index scope.scope_sub_scopes
in
Ast.Definition
( ( SubScopeVar {
( ( SubScopeVar
{
path = subscop_path;
scope = subscop_real_name;
alias = sub_scope_index, var_pos;
var =
match
(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 },
(* 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.D.scope_def_io,
Expr.unbox expr_def ))
sub_scope_vars_redefs_candidates
in
let sub_scope_vars_redefs =
D.ScopeDef.Map.values sub_scope_vars_redefs
in
let sub_scope_vars_redefs = D.ScopeDef.Map.values sub_scope_vars_redefs in
sub_scope_vars_redefs
@ [
Ast.Call
@ -698,9 +674,7 @@ let translate_scope_interface ctx scope =
match states with
| WholeVar ->
let scope_def =
D.ScopeDef.Map.find
(D.ScopeDef.Var (var, None))
scope.D.scope_defs
D.ScopeDef.Map.find (D.ScopeDef.Var (var, None)) scope.D.scope_defs
in
let typ = scope_def.scope_def_typ in
ScopeVar.Map.add
@ -742,8 +716,7 @@ let translate_scope
(ctx : ctx)
(exc_graphs :
Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t)
(scope : D.scope)
: untyped Ast.scope_decl Mark.pos =
(scope : D.scope) : untyped Ast.scope_decl Mark.pos =
let scope_dependencies =
Desugared.Dependency.build_scope_dependencies scope
in
@ -758,7 +731,8 @@ let translate_scope
scope_decl_rules @ new_rules)
[] scope_ordering
in
Mark.map (fun s -> { s with Ast.scope_decl_rules })
Mark.map
(fun s -> { s with Ast.scope_decl_rules })
(translate_scope_interface ctx scope)
(** {1 API} *)
@ -766,8 +740,8 @@ let translate_scope
let translate_program
(desugared : D.program)
(exc_graphs :
Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t)
: untyped Ast.program =
Desugared.Dependency.ExceptionsDependencies.t D.ScopeDef.Map.t) :
untyped Ast.program =
(* First we give mappings to all the locations between Desugared and This
involves creating a new Scopelang scope variable for every state of a
Desugared variable. *)
@ -782,8 +756,7 @@ let translate_program
let var_name, var_pos = ScopeVar.get_info scope_var in
let new_var =
match states with
| D.WholeVar ->
WholeVar (ScopeVar.fresh (var_name, var_pos))
| D.WholeVar -> WholeVar (ScopeVar.fresh (var_name, var_pos))
| States states ->
let var_prefix = var_name ^ "_" in
let state_var state =
@ -808,12 +781,18 @@ let translate_program
in
let ctx = make_ctx desugared in
let rec gather_scope_vars acc modules =
ModuleName.Map.fold (fun _modname mctx acc ->
ModuleName.Map.fold
(fun _modname mctx acc ->
let acc = gather_scope_vars acc mctx.modules in
ScopeVar.Map.union (fun _ _ -> assert false) acc mctx.scope_var_mapping)
modules acc
in
let ctx = { ctx with scope_var_mapping = gather_scope_vars ctx.scope_var_mapping ctx.modules } in
let ctx =
{
ctx with
scope_var_mapping = gather_scope_vars ctx.scope_var_mapping ctx.modules;
}
in
let rec process_decl_ctx ctx decl_ctx =
let ctx_scopes =
ScopeName.Map.map
@ -832,16 +811,20 @@ let translate_program
{ out_str with out_struct_fields })
decl_ctx.ctx_scopes
in
{ decl_ctx with
{
decl_ctx with
ctx_modules =
ModuleName.Map.mapi (fun modname decl_ctx ->
ModuleName.Map.mapi
(fun modname decl_ctx ->
let ctx = ModuleName.Map.find modname ctx.modules in
process_decl_ctx ctx decl_ctx)
decl_ctx.ctx_modules;
ctx_scopes; }
ctx_scopes;
}
in
let rec process_modules program_ctx desugared =
ModuleName.Map.mapi (fun modname m_desugared ->
ModuleName.Map.mapi
(fun modname m_desugared ->
let ctx = ModuleName.Map.find modname ctx.modules in
{
Ast.program_topdefs = TopdefName.Map.empty;
@ -869,7 +852,9 @@ let translate_program
desugared.program_topdefs
in
let program_scopes =
ScopeName.Map.map (translate_scope ctx exc_graphs) desugared.D.program_scopes
ScopeName.Map.map
(translate_scope ctx exc_graphs)
desugared.D.program_scopes
in
{
Ast.program_topdefs;

18
compiler/scopelang/print.ml
View File

@ -22,10 +22,10 @@ let struc
ctx
(fmt : Format.formatter)
(name : StructName.t)
(path, fields : path * typ StructField.Map.t) : unit =
Format.fprintf fmt "%a %a%a %a %a@\n@[<hov 2> %a@]@\n%a" Print.keyword "struct"
Print.path path
StructName.format name Print.punctuation "=" Print.punctuation "{"
((path, fields) : path * typ StructField.Map.t) : unit =
Format.fprintf fmt "%a %a%a %a %a@\n@[<hov 2> %a@]@\n%a" Print.keyword
"struct" Print.path path StructName.format name Print.punctuation "="
Print.punctuation "{"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (field_name, typ) ->
@ -38,10 +38,9 @@ let enum
ctx
(fmt : Format.formatter)
(name : EnumName.t)
(path, cases : path * typ EnumConstructor.Map.t) : unit =
((path, cases) : path * typ EnumConstructor.Map.t) : unit =
Format.fprintf fmt "%a %a%a %a @\n@[<hov 2> %a@]" Print.keyword "enum"
Print.path path
EnumName.format name Print.punctuation "="
Print.path path EnumName.format name Print.punctuation "="
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (field_name, typ) ->
@ -95,9 +94,8 @@ let scope ?debug ctx fmt (name, (decl, _pos)) =
Format.fprintf fmt "%a %a" Print.keyword "assert"
(Print.expr ?debug ()) e
| Call ((scope_path, scope_name), subscope_name, _) ->
Format.fprintf fmt "%a %a%a%a%a%a" Print.keyword "call"
Print.path scope_path
ScopeName.format scope_name Print.punctuation "["
Format.fprintf fmt "%a %a%a%a%a%a" Print.keyword "call" Print.path
scope_path ScopeName.format scope_name Print.punctuation "["
SubScopeName.format subscope_name Print.punctuation "]"))
decl.scope_decl_rules

47
compiler/shared_ast/definitions.ml
View File

@ -23,7 +23,9 @@
open Catala_utils
module Runtime = Runtime_ocaml.Runtime
module ModuleName = String
(* TODO: should probably be turned into an Uid once we implement module import directives; that will incur an additional resolution work on all paths though *)
(* TODO: should probably be turned into an Uid once we implement module import
directives; that will incur an additional resolution work on all paths
though *)
module ScopeName = Uid.Gen ()
module TopdefName = Uid.Gen ()
@ -314,8 +316,10 @@ type except = ConflictError | EmptyError | NoValueProvided | Crash
type untyped = { pos : Pos.t } [@@caml.unboxed]
type typed = { pos : Pos.t; ty : typ }
type 'a custom = { pos : Pos.t; custom : 'a }
(** Using empty markings will ensure terms can't be constructed: used for
example in interfaces to ensure that they don't contain any expressions *)
type nil = |
(** Using empty markings will ensure terms can't be constructed: used for example in interfaces to ensure that they don't contain any expressions *)
(** The generic type of AST markings. Using a GADT allows functions to be
polymorphic in the marking, but still do transformations on types when
@ -346,24 +350,34 @@ type lit =
type path = ModuleName.t Mark.pos list
(** External references are resolved to strings that point to functions or constants in the end, but we need to keep different references for typing *)
(** External references are resolved to strings that point to functions or
constants in the end, but we need to keep different references for typing *)
type external_ref =
| External_value of TopdefName.t
| External_scope of ScopeName.t
(** Locations are handled differently in [desugared] and [scopelang] *)
type 'a glocation =
| DesugaredScopeVar :
{ name: ScopeVar.t Mark.pos; state: StateName.t option }
| DesugaredScopeVar : {
name : ScopeVar.t Mark.pos;
state : StateName.t option;
}
-> < scopeVarStates : yes ; .. > glocation
| ScopelangScopeVar :
{ name: ScopeVar.t Mark.pos }
| ScopelangScopeVar : {
name : ScopeVar.t Mark.pos;
}
-> < scopeVarSimpl : yes ; .. > glocation
| SubScopeVar :
{ path: path; scope: ScopeName.t; alias: SubScopeName.t Mark.pos; var: ScopeVar.t Mark.pos }
| SubScopeVar : {
path : path;
scope : ScopeName.t;
alias : SubScopeName.t Mark.pos;
var : ScopeVar.t Mark.pos;
}
-> < explicitScopes : yes ; .. > glocation
| ToplevelVar :
{ path: path; name: TopdefName.t Mark.pos }
| ToplevelVar : {
path : path;
name : TopdefName.t Mark.pos;
}
-> < explicitScopes : yes ; .. > glocation
type ('a, 'm) gexpr = (('a, 'm) naked_gexpr, 'm) marked
@ -463,7 +477,11 @@ and ('a, 'b, 'm) base_gexpr =
-> ('a, < resolvedNames : yes ; .. >, 'm) base_gexpr
(** Resolved struct/enums, after [desugared] *)
(* Lambda-like *)
| EExternal : { path: path; name: external_ref Mark.pos} -> ('a, < explicitScopes: no ; .. >, 't) base_gexpr
| EExternal : {
path : path;
name : external_ref Mark.pos;
}
-> ('a, < explicitScopes : no ; .. >, 't) base_gexpr
| EAssert : ('a, 'm) gexpr -> ('a, < assertions : yes ; .. >, 'm) base_gexpr
(* Default terms *)
| EDefault : {
@ -595,7 +613,4 @@ type decl_ctx = {
ctx_modules : decl_ctx ModuleName.Map.t;
}
type 'e program = {
decl_ctx : decl_ctx;
code_items : 'e code_item_list;
}
type 'e program = { decl_ctx : decl_ctx; code_items : 'e code_item_list }

59
compiler/shared_ast/expr.ml
View File

@ -109,7 +109,10 @@ let subst binder vars =
Bindlib.msubst binder (Array.of_list (List.map Mark.remove vars))
let evar v mark = Mark.add mark (Bindlib.box_var v)
let eexternal ~path ~name mark = Mark.add mark (Bindlib.box (EExternal {path; name}))
let eexternal ~path ~name mark =
Mark.add mark (Bindlib.box (EExternal { path; name }))
let etuple args = Box.appn args @@ fun args -> ETuple args
let etupleaccess e index size =
@ -296,8 +299,7 @@ let map
estruct ~name ~fields m
| EDStructAccess { path; name_opt; field; e } ->
edstructaccess ~path ~name_opt ~field ~e:(f e) m
| EStructAccess { name; field; e } ->
estructaccess ~name ~field ~e:(f e) m
| EStructAccess { name; field; e } -> estructaccess ~name ~field ~e:(f e) m
| EMatch { name; e; cases } ->
let cases = EnumConstructor.Map.map f cases in
ematch ~name ~e:(f e) ~cases m
@ -516,31 +518,33 @@ let compare_lit (l1 : lit) (l2 : lit) =
| LDuration _, _ -> .
| _, LDuration _ -> .
let compare_path =
List.compare (Mark.compare ModuleName.compare)
let compare_path = List.compare (Mark.compare ModuleName.compare)
let compare_location
(type a)
(x : a glocation Mark.pos)
(y : a glocation Mark.pos) =
match Mark.remove x, Mark.remove y with
| DesugaredScopeVar { name = vx; state = None}, DesugaredScopeVar { name = vy; state = None}
| DesugaredScopeVar { name = vx; state = Some _}, DesugaredScopeVar { name = vy; state = None}
| DesugaredScopeVar { name = vx; state = None}, DesugaredScopeVar { name = vy; state = Some _} ->
| ( DesugaredScopeVar { name = vx; state = None },
DesugaredScopeVar { name = vy; state = None } )
| ( DesugaredScopeVar { name = vx; state = Some _ },
DesugaredScopeVar { name = vy; state = None } )
| ( DesugaredScopeVar { name = vx; state = None },
DesugaredScopeVar { name = vy; state = Some _ } ) ->
ScopeVar.compare (Mark.remove vx) (Mark.remove vy)
| DesugaredScopeVar {name = (x, _); state = Some sx}, DesugaredScopeVar {name = (y, _); state = Some sy} ->
| ( DesugaredScopeVar { name = x, _; state = Some sx },
DesugaredScopeVar { name = y, _; state = Some sy } ) ->
let cmp = ScopeVar.compare x y in
if cmp = 0 then StateName.compare sx sy else cmp
| ScopelangScopeVar { name = (vx, _) }, ScopelangScopeVar { name = (vy, _) } ->
| ScopelangScopeVar { name = vx, _ }, ScopelangScopeVar { name = vy, _ } ->
ScopeVar.compare vx vy
| ( SubScopeVar { alias = (xsubindex, _); var = (xsubvar, _); _},
SubScopeVar { alias = (ysubindex, _); var = (ysubvar, _); _} ) ->
| ( SubScopeVar { alias = xsubindex, _; var = xsubvar, _; _ },
SubScopeVar { alias = ysubindex, _; var = ysubvar, _; _ } ) ->
let c = SubScopeName.compare xsubindex ysubindex in
if c = 0 then ScopeVar.compare xsubvar ysubvar else c
| ToplevelVar { path = px; name = (vx, _) }, ToplevelVar { path = py; name = (vy, _) } ->
(match compare_path px py with
| 0 -> TopdefName.compare vx vy
| n -> n)
| ( ToplevelVar { path = px; name = vx, _ },
ToplevelVar { path = py; name = vy, _ } ) -> (
match compare_path px py with 0 -> TopdefName.compare vx vy | n -> n)
| DesugaredScopeVar _, _ -> -1
| _, DesugaredScopeVar _ -> 1
| ScopelangScopeVar _, _ -> -1
@ -554,11 +558,15 @@ let equal_path = List.equal (Mark.equal ModuleName.equal)
let equal_location a b = compare_location a b = 0
let equal_except ex1 ex2 = ex1 = ex2
let compare_except ex1 ex2 = Stdlib.compare ex1 ex2
let equal_external_ref ref1 ref2 = match ref1, ref2 with
let equal_external_ref ref1 ref2 =
match ref1, ref2 with
| External_value v1, External_value v2 -> TopdefName.equal v1 v2
| External_scope s1, External_scope s2 -> ScopeName.equal s1 s2
| (External_value _ | External_scope _), _ -> false
let compare_external_ref ref1 ref2 = match ref1, ref2 with
let compare_external_ref ref1 ref2 =
match ref1, ref2 with
| External_value v1, External_value v2 -> TopdefName.compare v1 v2
| External_scope s1, External_scope s2 -> ScopeName.compare s1 s2
| External_value _, _ -> -1
@ -609,12 +617,15 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool =
StructName.equal s1 s2 && StructField.Map.equal equal fields1 fields2
| ( EDStructAccess { e = e1; field = f1; name_opt = s1; path = p1 },
EDStructAccess { e = e2; field = f2; name_opt = s2; path = p2 } ) ->
Option.equal StructName.equal s1 s2 && equal_path p1 p2 && Ident.equal f1 f2 && equal e1 e2
Option.equal StructName.equal s1 s2
&& equal_path p1 p2
&& Ident.equal f1 f2
&& equal e1 e2
| ( EStructAccess { e = e1; field = f1; name = s1 },
EStructAccess { e = e2; field = f2; name = s2 } ) ->
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 } ->
| 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
| ( EMatch { e = e1; name = n1; cases = cases1 },
EMatch { e = e2; name = n2; cases = cases2 } ) ->
@ -623,9 +634,9 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool =
&& EnumConstructor.Map.equal equal cases1 cases2
| ( EScopeCall { path = p1; scope = s1; args = fields1 },
EScopeCall { path = p2; scope = s2; args = fields2 } ) ->
ScopeName.equal s1 s2 &&
equal_path p1 p2 &&
ScopeVar.Map.equal equal fields1 fields2
ScopeName.equal s1 s2
&& equal_path p1 p2
&& ScopeVar.Map.equal equal fields1 fields2
| ( ECustom { obj = obj1; targs = targs1; tret = tret1 },
ECustom { obj = obj2; targs = targs2; tret = tret2 } ) ->
Type.equal_list targs1 targs2 && Type.equal tret1 tret2 && obj1 == obj2

7
compiler/shared_ast/expr.mli
View File

@ -36,7 +36,12 @@ val rebox : ('a any, 'm) gexpr -> ('a, 'm) boxed_gexpr
(** Rebuild the whole term, re-binding all variables and exposing free variables *)
val evar : ('a, 'm) gexpr Var.t -> 'm mark -> ('a, 'm) boxed_gexpr
val eexternal : path:path -> name:external_ref Mark.pos -> 'm mark -> (< explicitScopes: no; .. >, 'm) boxed_gexpr
val eexternal :
path:path ->
name:external_ref Mark.pos ->
'm mark ->
(< explicitScopes : no ; .. >, 'm) boxed_gexpr
val bind :
('a, 'm) gexpr Var.t array ->

24
compiler/shared_ast/interpreter.ml
View File

@ -549,31 +549,33 @@ let rec evaluate_expr :
Message.raise_spanned_error pos
"free variable found at evaluation (should not happen if term was \
well-typed)"
| EExternal { path; name } -> (
| EExternal { path; name } ->
let ty =
try
let ctx = Program.module_ctx ctx path in
match Mark.remove name with
| External_value name ->
TopdefName.Map.find name ctx.ctx_topdefs
| External_value name -> TopdefName.Map.find name ctx.ctx_topdefs
| External_scope name ->
let scope_info = ScopeName.Map.find name ctx.ctx_scopes in
TArrow ([TStruct scope_info.in_struct_name, pos],
( TArrow
( [TStruct scope_info.in_struct_name, pos],
(TStruct scope_info.out_struct_name, pos) ),
pos
pos )
with TopdefName.Map.Not_found _ | ScopeName.Map.Not_found _ ->
Message.raise_spanned_error pos "Reference to %a%a could not be resolved"
Print.path path Print.external_ref name
Message.raise_spanned_error pos
"Reference to %a%a could not be resolved" Print.path path
Print.external_ref name
in
let runtime_path =
List.map Mark.remove path,
( List.map Mark.remove path,
match Mark.remove name with
| External_value name -> Mark.remove (TopdefName.get_info name)
| External_scope name -> Mark.remove (ScopeName.get_info name)
(* we have the guarantee that the two cases won't collide because they have different capitalisation rules inherited from the input *)
| External_scope name -> Mark.remove (ScopeName.get_info name) )
(* we have the guarantee that the two cases won't collide because they
have different capitalisation rules inherited from the input *)
in
let o = Runtime.lookup_value runtime_path in
runtime_to_val evaluate_expr ctx m ty o)
runtime_to_val evaluate_expr ctx m ty o
| EApp { f = e1; args } -> (
let e1 = evaluate_expr ctx e1 in
let args = List.map (evaluate_expr ctx) args in

9
compiler/shared_ast/optimizations.ml
View File

@ -409,10 +409,13 @@ let test_iota_reduction_2 () =
let matchA =
Expr.ematch
~e:(Expr.ematch ~e:(num 1) ~name:enumT
~cases:(cases_of_list
~e:
(Expr.ematch ~e:(num 1) ~name:enumT
~cases:
(cases_of_list
[
(consB, fun x -> injBe (injB x)); (consA, fun _x -> injAe (num 20));
(consB, fun x -> injBe (injB x));
(consA, fun _x -> injAe (num 20));
])
nomark)
~name:enumT

38
compiler/shared_ast/print.ml
View File

@ -73,10 +73,10 @@ let tlit (fmt : Format.formatter) (l : typ_lit) : unit =
let module_name ppf m = Format.fprintf ppf "@{<blue>%a@}" ModuleName.format m
let path ppf p =
Format.pp_print_list ~pp_sep:(fun _ () -> ())
Format.pp_print_list
~pp_sep:(fun _ () -> ())
(fun ppf m ->
Format.fprintf ppf "%a@{<cyan>.@}"
module_name (Mark.remove m))
Format.fprintf ppf "%a@{<cyan>.@}" module_name (Mark.remove m))
ppf p
let location (type a) (fmt : Format.formatter) (l : a glocation) : unit =
@ -103,11 +103,12 @@ let external_ref fmt er =
let rec module_ctx ctx = function
| [] -> ctx
| (modname, mpos) :: path ->
| (modname, mpos) :: path -> (
match ModuleName.Map.find_opt modname ctx.ctx_modules with
| None ->
Message.raise_spanned_error mpos "Module %a not found" ModuleName.format modname
| Some ctx -> module_ctx ctx path
Message.raise_spanned_error mpos "Module %a not found" ModuleName.format
modname
| Some ctx -> module_ctx ctx path)
let rec typ_gen
(ctx : decl_ctx option)
@ -137,15 +138,14 @@ let rec typ_gen
pp_color_string (List.hd colors) fmt ")"
| TStruct s -> (
match ctx with
| None ->
StructName.format fmt s
| None -> StructName.format fmt s
| Some ctx ->
let p, fields = StructName.Map.find s ctx.ctx_structs in
if StructField.Map.is_empty fields then
(path fmt p; StructName.format fmt s)
if StructField.Map.is_empty fields then (
path fmt p;
StructName.format fmt s)
else
Format.fprintf fmt "@[<hv 2>%a%a %a@,%a@;<0 -2>%a@]"
path p
Format.fprintf fmt "@[<hv 2>%a%a %a@,%a@;<0 -2>%a@]" path p
StructName.format s
(pp_color_string (List.hd colors))
"{"
@ -166,14 +166,14 @@ let rec typ_gen
| None -> Format.fprintf fmt "@[<hov 2>%a@]" EnumName.format e
| Some ctx ->
let p, def = EnumName.Map.find e ctx.ctx_enums in
Format.fprintf fmt "@[<hov 2>%a%a%a%a%a@]" path p EnumName.format e punctuation "["
Format.fprintf fmt "@[<hov 2>%a%a%a%a%a@]" path p EnumName.format e
punctuation "["
(EnumConstructor.Map.format_bindings
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ %a@ " punctuation "|")
(fun fmt pp_case mty ->
Format.fprintf fmt "%t%a@ %a" pp_case punctuation ":" (typ ~colors)
mty))
def
punctuation "]")
def punctuation "]")
| TOption t ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" base_type "eoption" (typ ~colors) t
| TArrow ([t1], t2) ->
@ -871,9 +871,9 @@ let enum
decl_ctx
fmt
(pp_name : Format.formatter -> unit)
(p, c : path * typ EnumConstructor.Map.t) =
Format.fprintf fmt "@[<h 0>%a %a%t %a@ %a@]" keyword "type" path p pp_name punctuation
"="
((p, c) : path * typ EnumConstructor.Map.t) =
Format.fprintf fmt "@[<h 0>%a %a%t %a@ %a@]" keyword "type" path p pp_name
punctuation "="
(EnumConstructor.Map.format_bindings
~pp_sep:(fun _ _ -> ())
(fun fmt pp_n ty ->
@ -888,7 +888,7 @@ let struct_
decl_ctx
fmt
(pp_name : Format.formatter -> unit)
(p, c : path * typ StructField.Map.t) =
((p, c) : path * typ StructField.Map.t) =
Format.fprintf fmt "@[<hv 0>@[<hv 2>@[<h>%a %a%t %a@;%a@]@;%a@]%a@]@;" keyword
"type" path p pp_name punctuation "=" punctuation "{"
(StructField.Map.format_bindings

7
compiler/shared_ast/program.ml
View File

@ -41,11 +41,12 @@ let empty_ctx =
let rec module_ctx ctx = function
| [] -> ctx
| (modname, mpos) :: path ->
| (modname, mpos) :: path -> (
match ModuleName.Map.find_opt modname ctx.ctx_modules with
| None ->
Message.raise_spanned_error mpos "Module %a not found" ModuleName.format modname
| Some ctx -> module_ctx ctx path
Message.raise_spanned_error mpos "Module %a not found" ModuleName.format
modname
| Some ctx -> module_ctx ctx path)
let get_scope_body { code_items; _ } scope =
match

3
compiler/shared_ast/program.mli
View File

@ -23,7 +23,8 @@ open Definitions
val empty_ctx : decl_ctx
val module_ctx : decl_ctx -> ModuleName.t Mark.pos list -> decl_ctx
(** Follows a path to get the corresponding context for type and value declarations. Errors out if the module is not found *)
(** Follows a path to get the corresponding context for type and value
declarations. Errors out if the module is not found *)
(** {2 Transformations} *)

4
compiler/shared_ast/scope.mli
View File

@ -1,5 +1,5 @@
(* This file is part of the Catala compiler, a specification language for tax
< and social benefits computation rules. Copyright (C) 2020-2022 Inria,
(* This file is part of the Catala compiler, a specification language for tax <
and social benefits computation rules. Copyright (C) 2020-2022 Inria,
contributor: Denis Merigoux <denis.merigoux@inria.fr>, Alain Delaët-Tixeuil
<alain.delaet--tixeuil@inria.fr>, Louis Gesbert <louis.gesbert@inria.fr>

65
compiler/shared_ast/typing.ml
View File

@ -125,13 +125,16 @@ let rec format_typ
"("
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ *@ ")
(fun fmt t ->
format_typ fmt ~colors:(List.tl colors) t))
(fun fmt t -> format_typ fmt ~colors:(List.tl colors) t))
ts
(pp_color_string (List.hd colors))
")"
| TStruct s -> Print.path fmt (fst (A.StructName.Map.find s ctx.A.ctx_structs)); A.StructName.format fmt s
| TEnum e -> Print.path fmt (fst (A.EnumName.Map.find e ctx.A.ctx_enums)); A.EnumName.format fmt e
| TStruct s ->
Print.path fmt (fst (A.StructName.Map.find s ctx.A.ctx_structs));
A.StructName.format fmt s
| TEnum e ->
Print.path fmt (fst (A.EnumName.Map.find e ctx.A.ctx_enums));
A.EnumName.format fmt e
| TOption t ->
Format.fprintf fmt "@[<hov 2>option %a@]"
(format_typ_with_parens ~colors:(List.tl colors))
@ -346,10 +349,12 @@ module Env = struct
let rec module_env path env =
match path with
| [] -> env
| (modname, mpos) :: path ->
| (modname, mpos) :: path -> (
match A.ModuleName.Map.find_opt modname env.modules with
| None -> Message.raise_spanned_error mpos "Module %a not found" A.ModuleName.format modname
| Some env -> module_env path env
| None ->
Message.raise_spanned_error mpos "Module %a not found"
A.ModuleName.format modname
| Some env -> module_env path env)
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
@ -447,12 +452,8 @@ and typecheck_expr_top_down :
Expr.elocation loc (mark_with_tau_and_unify (ast_to_typ ty))
| A.EStruct { name; fields } ->
let mark = ty_mark (TStruct name) in
let _path, str_ast =
A.StructName.Map.find name ctx.A.ctx_structs
in
let str =
A.StructName.Map.find name env.structs
in
let _path, str_ast = A.StructName.Map.find name ctx.A.ctx_structs in
let str = A.StructName.Map.find name env.structs in
let _check_fields : unit =
let missing_fields, extra_fields =
A.StructField.Map.fold
@ -627,14 +628,11 @@ and typecheck_expr_top_down :
in
Expr.ematch ~e:e1' ~name ~cases mark
| A.EMatch { e = e1; name; cases } ->
let _path, cases_ty =
A.EnumName.Map.find name ctx.A.ctx_enums
in
let _path, cases_ty = A.EnumName.Map.find name ctx.A.ctx_enums in
let t_ret = unionfind ~pos:e1 (TAny (Any.fresh ())) in
let mark = mark_with_tau_and_unify t_ret in
let e1' =
typecheck_expr_top_down ~leave_unresolved ctx env
(unionfind (TEnum name))
typecheck_expr_top_down ~leave_unresolved ctx env (unionfind (TEnum name))
e1
in
let cases =
@ -688,20 +686,21 @@ and typecheck_expr_top_down :
let ty =
let not_found pr x =
Message.raise_spanned_error pos_e
"Could not resolve the reference to %a%a.@ Make sure the corresponding \
module was properly loaded?"
Print.path path
pr x
"Could not resolve the reference to %a%a.@ Make sure the \
corresponding module was properly loaded?"
Print.path path pr x
in
match Mark.remove name with
| A.External_value name ->
(try
ast_to_typ (A.TopdefName.Map.find name ctx.ctx_topdefs)
with A.TopdefName.Map.Not_found _ -> not_found A.TopdefName.format name)
| A.External_scope name ->
(try
| A.External_value name -> (
try ast_to_typ (A.TopdefName.Map.find name ctx.ctx_topdefs)
with A.TopdefName.Map.Not_found _ ->
not_found A.TopdefName.format name)
| A.External_scope name -> (
try
let scope_info = A.ScopeName.Map.find name ctx.ctx_scopes in
ast_to_typ (TArrow ([TStruct scope_info.in_struct_name, pos_e],
ast_to_typ
( TArrow
( [TStruct scope_info.in_struct_name, pos_e],
(TStruct scope_info.out_struct_name, pos_e) ),
pos_e )
with A.ScopeName.Map.Not_found _ -> not_found A.ScopeName.format name)
@ -1033,7 +1032,7 @@ let program ~leave_unresolved prg =
ctx_structs =
A.StructName.Map.mapi
(fun s_name (path, fields) ->
path,
( path,
A.StructField.Map.mapi
(fun f_name (t : A.typ) ->
match Mark.remove t with
@ -1042,12 +1041,12 @@ let program ~leave_unresolved prg =
(A.StructField.Map.find f_name
(A.StructName.Map.find s_name new_env.structs))
| _ -> t)
fields)
fields ))
prg.decl_ctx.ctx_structs;
ctx_enums =
A.EnumName.Map.mapi
(fun e_name (path, cons) ->
path,
( path,
A.EnumConstructor.Map.mapi
(fun cons_name (t : A.typ) ->
match Mark.remove t with
@ -1056,7 +1055,7 @@ let program ~leave_unresolved prg =
(A.EnumConstructor.Map.find cons_name
(A.EnumName.Map.find e_name new_env.enums))
| _ -> t)
cons)
cons ))
prg.decl_ctx.ctx_enums;
};
}

1
compiler/shared_ast/var.ml
View File

@ -92,6 +92,7 @@ module Map = struct
open M
type k0 = M.key
exception Not_found = M.Not_found
type nonrec ('e, 'x) t = 'x t

2
compiler/shared_ast/var.mli
View File

@ -57,8 +57,8 @@ end
Extend as needed *)
module Map : sig
type ('e, 'x) t
type k0
exception Not_found of k0
val empty : ('e, 'x) t

3
compiler/surface/ast.ml
View File

@ -310,7 +310,8 @@ and law_structure =
| CodeBlock of code_block * source_repr * bool (* Metadata if true *)
and interface = code_block
(** Invariant: an interface shall only contain [*Decl] elements, or [Topdef] elements with [topdef_expr = None] *)
(** Invariant: an interface shall only contain [*Decl] elements, or [Topdef]
elements with [topdef_expr = None] *)
and program = {
program_items : law_structure list;

8
compiler/surface/parser_driver.ml
View File

@ -231,7 +231,7 @@ let rec parse_source_file
{
program_items = program.Ast.program_items;
program_source_files = source_file_name :: program.Ast.program_source_files;
program_modules = []
program_modules = [];
}
(** Expands the include directives in a parsing result, thus parsing new source
@ -267,8 +267,7 @@ and expand_includes
Ast.program_source_files = acc.Ast.program_source_files @ new_sources;
Ast.program_items =
acc.Ast.program_items @ [Ast.LawHeading (heading, commands')];
Ast.program_modules =
acc.Ast.program_modules @ new_modules;
Ast.program_modules = acc.Ast.program_modules @ new_modules;
}
| i -> { acc with Ast.program_items = acc.Ast.program_items @ [i] })
{
@ -302,8 +301,7 @@ let get_interface program =
(** {1 API} *)
let load_interface source_file language =
parse_source_file source_file language
|> get_interface
parse_source_file source_file language |> get_interface
let parse_top_level_file
(source_file : Cli.input_file)

11
compiler/surface/parser_driver.mli
View File

@ -19,11 +19,10 @@
open Catala_utils
val load_interface :
Cli.input_file ->
Cli.backend_lang ->
Ast.interface
(** Reads only declarations in metadata in the supplied input file, and only keeps type information *)
val load_interface : Cli.input_file -> Cli.backend_lang -> Ast.interface
(** Reads only declarations in metadata in the supplied input file, and only
keeps type information *)
val parse_top_level_file : Cli.input_file -> Cli.backend_lang -> Ast.program
(** Parses a catala file (handling file includes) and returns a program. Modules in the program are returned empty, use [load_interface] to fill them. *)
(** Parses a catala file (handling file includes) and returns a program. Modules
in the program are returned empty, use [load_interface] to fill them. *)

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

@ -667,11 +667,7 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
accesses *)
let accessors = List.hd (Datatype.get_accessors z3_struct) in
let _path, fields = StructName.Map.find name ctx.ctx_decl.ctx_structs in
let idx_mappings =
List.combine
(StructField.Map.keys fields)
accessors
in
let idx_mappings = List.combine (StructField.Map.keys fields) accessors in
let _, accessor =
List.find (fun (field1, _) -> StructField.equal field field1) idx_mappings
in
@ -687,11 +683,7 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
let ctrs = Datatype.get_constructors z3_enum in
let _path, cons_map = EnumName.Map.find name ctx.ctx_decl.ctx_enums in
(* This should always succeed if the expression is well-typed in dcalc *)
let idx_mappings =
List.combine
(EnumConstructor.Map.keys cons_map)
ctrs
in
let idx_mappings = List.combine (EnumConstructor.Map.keys cons_map) ctrs in
let _, ctr =
List.find
(fun (cons1, _) -> EnumConstructor.equal cons cons1)