CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'master' into aides_logement_outre_mer

Browse Source
This commit is contained in:
Denis Merigoux 2023-02-28 14:52:18 +01:00
commit 0667e3d40f
No known key found for this signature in database
GPG Key ID: EE99DCFA365C3EE3
76 changed files with 21116 additions and 12875 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
.github/workflows/run-builds.yml vendored
View File

@ -1,15 +1,38 @@
name: Builds
name: "nix CI"
on:
push:
branches: [master]
workflow_dispatch:
jobs:
build-nix-flake:
build:
runs-on: ubuntu-latest
steps:
- uses: actions/checkout@v2.3.4
- uses: cachix/install-nix-action@v15
- run: nix build
- run: nix develop -c echo ok
- uses: actions/checkout@v3
- uses: cachix/install-nix-action@v18
with:
nix_path: nixpkgs=channel:nixos-unstable
- id: cache-restore
uses: actions/cache/restore@v3
with:
path: nix-store.nar
key: nix-store-nar-${{ hashFiles('flake.lock') }}
- if: steps.cache-restore.outputs.cache-hit == 'true'
run: |
nix-store --import < nix-store.nar
rm nix-store.nar
- run: nix develop
- run: nix build
- run: nix build .#clerk
- name: dump store
if: steps.cache-restore.outputs.cache-hit == 'false'
run: nix-store --export $(nix-store -qR $(nix print-dev-env --json | jq .variables.prefix.value -r)) > nix-store.nar
- name: save current cache
if: steps.cache-restore.outputs.cache-hit == 'false'
uses: actions/cache/save@v3
id: cache
with:
path: nix-store.nar
key: nix-store-nar-${{ hashFiles('flake.lock') }}

11
.github/workflows/update-flake-lock.yml vendored
View File

@ -16,12 +16,15 @@ jobs:
- name: update flake.lock
run: |
nix flake update
- name: check it builds
- name: check catala builds
run: |
nix build
- name: check clerk builds and catala test-suite passes
run: |
nix build .#clerk
- name: commit changes
uses: EndBug/add-and-commit@v9
with:
author_name: Catala nix updated
author_email: nixer@catala
message: "update lock files"
author_name: adelaett
author_email: 90894311+adelaett@users.noreply.github.com
message: "Update lock files"

2
.gitignore vendored
View File

@ -13,3 +13,5 @@ legifrance_oauth*
node_modules/
build.ninja
.envrc
.direnv

14
.nix/catala.nix
View File

@ -12,7 +12,7 @@
, js_of_ocaml
, js_of_ocaml-ppx
, menhir
, menhirLib ? null #for nixos-unstable compatibility.
, menhirLib
, ocamlgraph
, pkgs
, ppx_deriving
@ -27,7 +27,7 @@
, zarith_stubs_js
}:
buildDunePackage rec {
buildDunePackage {
pname = "catala";
version = "0.7.0"; # TODO parse `catala.opam` with opam2json
@ -37,17 +37,17 @@ buildDunePackage rec {
duneVersion = "3";
nativeBuildInputs = [ cppo menhir ];
propagatedBuildInputs = [
alcotest
ansiterminal
benchmark
bindlib
cmdliner
cppo
dates_calc
js_of_ocaml
js_of_ocaml-ppx
menhir
menhirLib
ocamlgraph
pkgs.z3
@ -61,8 +61,10 @@ buildDunePackage rec {
z3
zarith
zarith_stubs_js
] ++ (if isNull menhirLib then [ ] else [ menhirLib ]);
doCheck = true;
];
# Currently there is no unit tests in catala and Cram tests are handled by clerk
doCheck = false;
meta = with lib; {
homepage = "https://catala-lang.org";

13
.nix/clerk.nix
View File

@ -3,13 +3,15 @@
, odoc
, re
, ansiterminal
, cmdliner_1_1_0
, cmdliner
, ninja_utils
, alcotest
, catala
, ninja
, colordiff
}:
buildDunePackage rec {
buildDunePackage {
pname = "clerk";
version = "0.7.0"; # TODO parse `catala.opam` with opam2json
@ -23,12 +25,15 @@ buildDunePackage rec {
odoc
re
ansiterminal
cmdliner_1_1_0
cmdliner
ninja_utils
alcotest
catala
];
doCheck = false;
# todo: the current colordiff in nixpkgs always prints the banner. This make the logs totally unreadable.
nativeBuildInputs = [ catala ninja colordiff ];
doCheck = true;
meta = with lib; {
homepage = "https://github.com/CatalaLang/catala";

236
compiler/dcalc/from_scopelang.ml
View File

@ -49,8 +49,9 @@ type 'm scope_sigs_ctx = 'm scope_sig_ctx ScopeName.Map.t
type 'm ctx = {
structs : struct_ctx;
enums : enum_ctx;
scope_name : ScopeName.t;
scope_name : ScopeName.t option;
scopes_parameters : 'm scope_sigs_ctx;
toplevel_vars : ('m Ast.expr Var.t * naked_typ) TopdefName.Map.t;
scope_vars :
('m Ast.expr Var.t * naked_typ * Desugared.Ast.io) ScopeVar.Map.t;
subscope_vars :
@ -59,21 +60,6 @@ type 'm ctx = {
local_vars : ('m Scopelang.Ast.expr, 'm Ast.expr Var.t) Var.Map.t;
}
let empty_ctx
(struct_ctx : struct_ctx)
(enum_ctx : enum_ctx)
(scopes_ctx : 'm scope_sigs_ctx)
(scope_name : ScopeName.t) =
{
structs = struct_ctx;
enums = enum_ctx;
scope_name;
scopes_parameters = scopes_ctx;
scope_vars = ScopeVar.Map.empty;
subscope_vars = SubScopeName.Map.empty;
local_vars = Var.Map.empty;
}
let mark_tany m pos = Expr.with_ty m (Marked.mark pos TAny) ~pos
(* Expression argument is used as a type witness, its type and positions aren't
@ -222,6 +208,9 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
Expr.estruct name fields m
| EStructAccess { e; field; name } ->
Expr.estructaccess (translate_expr ctx e) field name m
| ETuple es -> Expr.etuple (List.map (translate_expr ctx) es) m
| ETupleAccess { e; index; size } ->
Expr.etupleaccess (translate_expr ctx e) index size m
| EInj { e; cons; name } ->
let e' = translate_expr ctx e in
Expr.einj e' cons name m
@ -363,33 +352,39 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
field sc_sig.scope_sig_output_struct (Expr.with_ty m typ)
in
match Marked.unmark typ with
| TArrow (t_in, t_out) ->
| TArrow (ts_in, t_out) ->
(* Here the output scope struct field is a function so we
eta-expand it and insert logging instructions. Invariant:
works because user-defined functions in scope have only one
argument. *)
let param_var = Var.make "param" in
works because there is no partial evaluation. *)
let params_vars =
ListLabels.mapi ts_in ~f:(fun i _ ->
Var.make ("param" ^ string_of_int i))
in
let f_markings =
[ScopeName.get_info scope; StructField.get_info field]
in
Expr.make_abs
(Array.of_list [param_var])
(Array.of_list params_vars)
(tag_with_log_entry
(tag_with_log_entry
(Expr.eapp
(tag_with_log_entry original_field_expr BeginCall
f_markings)
[
tag_with_log_entry
(Expr.make_var param_var (Expr.with_ty m t_in))
(VarDef (Marked.unmark t_in))
(f_markings @ [Marked.mark (Expr.pos e) "input"]);
]
(ListLabels.mapi (List.combine params_vars ts_in)
~f:(fun i (param_var, t_in) ->
tag_with_log_entry
(Expr.make_var param_var (Expr.with_ty m t_in))
(VarDef (Marked.unmark t_in))
(f_markings
@ [
Marked.mark (Expr.pos e)
("input" ^ string_of_int i);
])))
(Expr.with_ty m t_out))
(VarDef (Marked.unmark t_out))
(f_markings @ [Marked.mark (Expr.pos e) "output"]))
EndCall f_markings)
[t_in] (Expr.pos e)
ts_in (Expr.pos e)
| _ -> original_field_expr)
(StructName.Map.find sc_sig.scope_sig_output_struct ctx.structs))
(Expr.with_ty m (TStruct sc_sig.scope_sig_output_struct, Expr.pos e))
@ -434,20 +429,24 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
(* We insert various log calls to record arguments and outputs of
user-defined functions belonging to scopes *)
let e1_func = translate_expr ctx f in
let markings l =
match l with
| ScopelangScopeVar (v, _) ->
[ScopeName.get_info ctx.scope_name; ScopeVar.get_info v]
| SubScopeVar (s, _, (v, _)) ->
[ScopeName.get_info s; ScopeVar.get_info v]
let markings =
match ctx.scope_name, Marked.unmark f with
| Some sname, ELocation loc -> (
match loc with
| ScopelangScopeVar (v, _) ->
[ScopeName.get_info sname; ScopeVar.get_info v]
| SubScopeVar (s, _, (v, _)) ->
[ScopeName.get_info s; ScopeVar.get_info v]
| ToplevelVar _ -> [])
| _ -> []
in
let e1_func =
match Marked.unmark f with
| ELocation l -> tag_with_log_entry e1_func BeginCall (markings l)
| _ -> e1_func
match markings with
| [] -> e1_func
| m -> tag_with_log_entry e1_func BeginCall m
in
let new_args = List.map (translate_expr ctx) args in
let input_typ, output_typ =
let input_typs, output_typ =
(* NOTE: this is a temporary solution, it works because it's assume that
all function calls are from scope variable. However, this will change
-- for more information see
@ -456,8 +455,9 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
let _, typ, _ = ScopeVar.Map.find (Marked.unmark var) vars in
match typ with
| TArrow (marked_input_typ, marked_output_typ) ->
Marked.unmark marked_input_typ, Marked.unmark marked_output_typ
| _ -> TAny, TAny
( List.map Marked.unmark marked_input_typ,
Marked.unmark marked_output_typ )
| _ -> ListLabels.map new_args ~f:(fun _ -> TAny), TAny
in
match Marked.unmark f with
| ELocation (ScopelangScopeVar var) ->
@ -466,26 +466,40 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
ctx.subscope_vars
|> SubScopeName.Map.find (Marked.unmark sname)
|> retrieve_in_and_out_typ_or_any var
| _ -> TAny, TAny
| ELocation (ToplevelVar tvar) -> (
let _, typ =
TopdefName.Map.find (Marked.unmark tvar) ctx.toplevel_vars
in
match typ with
| TArrow (tin, (tout, _)) -> List.map Marked.unmark tin, tout
| _ ->
Errors.raise_spanned_error (Expr.pos e)
"Application of non-function toplevel variable")
| _ -> ListLabels.map new_args ~f:(fun _ -> TAny), TAny
in
(* Cli.debug_format "new_args %d, input_typs: %d, input_typs %a"
(List.length new_args) (List.length input_typs) (Format.pp_print_list
Print.typ_debug) (List.map (Marked.mark Pos.no_pos) input_typs); *)
let new_args =
match Marked.unmark f, new_args with
| ELocation l, [new_arg] ->
[
tag_with_log_entry new_arg (VarDef input_typ)
(markings l @ [Marked.mark (Expr.pos e) "input"]);
]
| _ -> new_args
ListLabels.mapi (List.combine new_args input_typs)
~f:(fun i (new_arg, input_typ) ->
match markings with
| _ :: _ as m ->
tag_with_log_entry new_arg (VarDef input_typ)
(m @ [Marked.mark (Expr.pos e) ("input" ^ string_of_int i)])
| _ -> new_arg)
in
let new_e = Expr.eapp e1_func new_args m in
let new_e =
match Marked.unmark f with
| ELocation l ->
match markings with
| [] -> new_e
| m ->
tag_with_log_entry
(tag_with_log_entry new_e (VarDef output_typ)
(markings l @ [Marked.mark (Expr.pos e) "output"]))
EndCall (markings l)
| _ -> new_e
(m @ [Marked.mark (Expr.pos e) "output"]))
EndCall m
in
new_e
| EAbs { binder; tys } ->
@ -533,6 +547,9 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
%a's results. Maybe you forgot to qualify it as an output?"
SubScopeName.format_t (Marked.unmark s) ScopeVar.format_t
(Marked.unmark a) SubScopeName.format_t (Marked.unmark s))
| ELocation (ToplevelVar v) ->
let v, _ = TopdefName.Map.find (Marked.unmark v) ctx.toplevel_vars in
Expr.evar v m
| EIfThenElse { cond; etrue; efalse } ->
Expr.eifthenelse (translate_expr ctx cond) (translate_expr ctx etrue)
(translate_expr ctx efalse)
@ -632,7 +649,7 @@ let translate_rule
| OnlyInput -> tau
| Reentrant ->
if is_func then tau
else TArrow ((TLit TUnit, var_def_pos), tau), var_def_pos);
else TArrow ([TLit TUnit, var_def_pos], tau), var_def_pos);
scope_let_expr = thunked_or_nonempty_new_e;
scope_let_kind = SubScopeVarDefinition;
})
@ -655,6 +672,11 @@ let translate_rule
(a_var, Marked.unmark tau, a_io)))
ctx.subscope_vars;
} )
| Definition ((ToplevelVar _, _), _, _, _) ->
assert false
(* A global variable can't be defined locally. The [Definition] constructor
could be made more specific to avoid this case, but the added complexity
didn't seem worth it *)
| Call (subname, subindex, m) ->
let subscope_sig = ScopeName.Map.find subname ctx.scopes_parameters in
let all_subscope_vars = subscope_sig.scope_sig_local_vars in
@ -858,15 +880,16 @@ let translate_rules
new_ctx )
let translate_scope_decl
(struct_ctx : struct_ctx)
(enum_ctx : enum_ctx)
(sctx : 'm scope_sigs_ctx)
(ctx : 'm ctx)
(scope_name : ScopeName.t)
(sigma : 'm Scopelang.Ast.scope_decl) :
'm Ast.expr scope_body Bindlib.box * struct_ctx =
let sigma_info = ScopeName.get_info sigma.scope_decl_name in
let scope_sig = ScopeName.Map.find sigma.scope_decl_name sctx in
let scope_sig =
ScopeName.Map.find sigma.scope_decl_name ctx.scopes_parameters
in
let scope_variables = scope_sig.scope_sig_local_vars in
let ctx = { ctx with scope_name = Some scope_name } in
let ctx =
(* the context must be initialized for fresh variables for all only-input
scope variables *)
@ -886,8 +909,7 @@ let translate_scope_decl
ctx.scope_vars;
}
| _ -> ctx)
(empty_ctx struct_ctx enum_ctx sctx scope_name)
scope_variables
ctx scope_variables
in
let scope_input_var = scope_sig.scope_sig_input_var in
let scope_input_struct_name = scope_sig.scope_sig_input_struct in
@ -922,7 +944,7 @@ let translate_scope_decl
match var_ctx.scope_var_typ with
| TArrow _ -> var_ctx.scope_var_typ, pos_sigma
| _ ->
( TArrow ((TLit TUnit, pos_sigma), (var_ctx.scope_var_typ, pos_sigma)),
( TArrow ([TLit TUnit, pos_sigma], (var_ctx.scope_var_typ, pos_sigma)),
pos_sigma ))
| NoInput -> failwith "should not happen"
in
@ -978,10 +1000,10 @@ let translate_scope_decl
new_struct_ctx )
let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
let scope_dependencies = Scopelang.Dependency.build_program_dep_graph prgm in
Scopelang.Dependency.check_for_cycle_in_scope scope_dependencies;
let scope_ordering =
Scopelang.Dependency.get_scope_ordering scope_dependencies
let defs_dependencies = Scopelang.Dependency.build_program_dep_graph prgm in
Scopelang.Dependency.check_for_cycle_in_defs defs_dependencies;
let defs_ordering =
Scopelang.Dependency.get_defs_ordering defs_dependencies
in
let decl_ctx = prgm.program_ctx in
let sctx : 'm scope_sigs_ctx =
@ -1036,36 +1058,68 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
scope_sig_in_fields;
scope_sig_out_fields = scope_return.out_struct_fields;
})
prgm.program_scopes
prgm.Scopelang.Ast.program_scopes
in
let top_ctx =
let toplevel_vars =
TopdefName.Map.mapi
(fun name (_, ty) ->
Var.make (Marked.unmark (TopdefName.get_info name)), Marked.unmark ty)
prgm.Scopelang.Ast.program_topdefs
in
{
structs = decl_ctx.ctx_structs;
enums = decl_ctx.ctx_enums;
scope_name = None;
scopes_parameters = sctx;
scope_vars = ScopeVar.Map.empty;
subscope_vars = SubScopeName.Map.empty;
local_vars = Var.Map.empty;
toplevel_vars;
}
in
(* the resulting expression is the list of definitions of all the scopes,
ending with the top-level scope. The decl_ctx is filled in left-to-right
order, then the chained scopes aggregated from the right. *)
let rec translate_scopes decl_ctx = function
| scope_name :: next_scopes ->
let scope = ScopeName.Map.find scope_name prgm.program_scopes in
let scope_body, scope_in_struct =
translate_scope_decl decl_ctx.ctx_structs decl_ctx.ctx_enums sctx
scope_name scope
let rec translate_defs ctx = function
| [] -> Bindlib.box Nil, ctx
| def :: next ->
let ctx, dvar, def =
match def with
| Scopelang.Dependency.Topdef gname ->
let expr, ty = TopdefName.Map.find gname prgm.program_topdefs in
let expr = translate_expr ctx expr in
( ctx,
fst (TopdefName.Map.find gname ctx.toplevel_vars),
Bindlib.box_apply
(fun e -> Topdef (gname, ty, e))
(Expr.Box.lift expr) )
| Scopelang.Dependency.Scope scope_name ->
let scope = ScopeName.Map.find scope_name prgm.program_scopes in
let scope_body, scope_in_struct =
translate_scope_decl ctx scope_name scope
in
( {
ctx with
structs =
StructName.Map.union
(fun _ _ -> assert false)
ctx.structs scope_in_struct;
},
(ScopeName.Map.find scope_name sctx).scope_sig_scope_var,
Bindlib.box_apply
(fun body -> ScopeDef (scope_name, body))
scope_body )
in
let dvar = (ScopeName.Map.find scope_name sctx).scope_sig_scope_var in
let decl_ctx =
{
decl_ctx with
ctx_structs =
StructName.Map.union
(fun _ _ -> assert false (* should not happen *))
decl_ctx.ctx_structs scope_in_struct;
}
in
let scope_next, decl_ctx = translate_scopes decl_ctx next_scopes in
let scope_next, ctx = translate_defs ctx next in
let next_bind = Bindlib.bind_var dvar scope_next in
( Bindlib.box_apply2
(fun scope_body scope_next ->
ScopeDef { scope_name; scope_body; scope_next })
scope_body
(Bindlib.bind_var dvar scope_next),
decl_ctx )
| [] -> Bindlib.box Nil, decl_ctx
(fun item next_bind -> Cons (item, next_bind))
def next_bind,
ctx )
in
let scopes, decl_ctx = translate_scopes decl_ctx scope_ordering in
{ scopes = Bindlib.unbox scopes; decl_ctx }
let items, ctx = translate_defs top_ctx defs_ordering in
{
code_items = Bindlib.unbox items;
decl_ctx = { decl_ctx with ctx_structs = ctx.structs };
}

17
compiler/dcalc/interpreter.ml
View File

@ -314,7 +314,7 @@ and evaluate_expr (ctx : decl_ctx) (e : 'm Ast.expr) : 'm Ast.expr =
| EVar _ ->
Errors.raise_spanned_error (Expr.pos e)
"free variable found at evaluation (should not happen if term was \
well-typed"
well-typed)"
| EApp { f = e1; args } -> (
let e1 = evaluate_expr ctx e1 in
let args = List.map (evaluate_expr ctx) args in
@ -364,6 +364,17 @@ and evaluate_expr (ctx : decl_ctx) (e : 'm Ast.expr) : 'm Ast.expr =
if the term was well-typed)"
(Expr.format ctx ~debug:true)
e StructName.format_t s)
| ETuple es ->
Marked.same_mark_as (ETuple (List.map (evaluate_expr ctx) es)) e
| ETupleAccess { e = e1; index; size } -> (
match evaluate_expr ctx e1 with
| ETuple es, _ when List.length es = size -> List.nth es index
| e ->
Errors.raise_spanned_error (Expr.pos e)
"The expression %a was expected to be a tuple of size %d (should not \
happen if the term was well-typed)"
(Expr.format ctx ~debug:true)
e size)
| EInj { e = e1; name; cons } ->
let e1' = evaluate_expr ctx e1 in
if is_empty_error e then Marked.same_mark_as (ELit LEmptyError) e
@ -511,9 +522,9 @@ let interpret_program :
match Marked.unmark ty with
| TArrow (ty_in, ty_out) ->
Expr.make_abs
[| Var.make "_" |]
(Array.of_list @@ List.map (fun _ -> Var.make "_") ty_in)
(Bindlib.box (ELit LEmptyError), Expr.with_ty mark_e ty_out)
[ty_in] (Expr.mark_pos mark_e)
ty_in (Expr.mark_pos mark_e)
| _ ->
Errors.raise_spanned_error (Marked.get_mark ty)
"This scope needs input arguments to be executed. But the Catala \

69
compiler/dcalc/optimizations.ml
View File

@ -213,70 +213,11 @@ let rec partial_evaluation (ctx : partial_evaluation_ctx) (e : 'm expr) :
let optimize_expr (decl_ctx : decl_ctx) (e : 'm expr) =
partial_evaluation { var_values = Var.Map.empty; decl_ctx } e
let rec scope_lets_map
(t : 'a -> 'm expr -> (dcalc, 'm mark) boxed_gexpr)
(ctx : 'a)
(scope_body_expr : 'm expr scope_body_expr) :
'm expr scope_body_expr Bindlib.box =
match scope_body_expr with
| Result e ->
Bindlib.box_apply (fun e' -> Result e') (Expr.Box.lift (t ctx e))
| ScopeLet scope_let ->
let var, next = Bindlib.unbind scope_let.scope_let_next in
let new_scope_let_expr = Expr.Box.lift (t ctx scope_let.scope_let_expr) in
let new_next = scope_lets_map t ctx next in
let new_next = Bindlib.bind_var var new_next in
Bindlib.box_apply2
(fun new_scope_let_expr new_next ->
ScopeLet
{
scope_let with
scope_let_expr = new_scope_let_expr;
scope_let_next = new_next;
})
new_scope_let_expr new_next
let rec scopes_map
(t : 'a -> 'm expr -> (dcalc, 'm mark) boxed_gexpr)
(ctx : 'a)
(scopes : 'm expr scopes) : 'm expr scopes Bindlib.box =
match scopes with
| Nil -> Bindlib.box Nil
| ScopeDef scope_def ->
let scope_var, scope_next = Bindlib.unbind scope_def.scope_next in
let scope_arg_var, scope_body_expr =
Bindlib.unbind scope_def.scope_body.scope_body_expr
in
let new_scope_body_expr = scope_lets_map t ctx scope_body_expr in
let new_scope_body_expr =
Bindlib.bind_var scope_arg_var new_scope_body_expr
in
let new_scope_next = scopes_map t ctx scope_next in
let new_scope_next = Bindlib.bind_var scope_var new_scope_next in
Bindlib.box_apply2
(fun new_scope_body_expr new_scope_next ->
ScopeDef
{
scope_def with
scope_next = new_scope_next;
scope_body =
{
scope_def.scope_body with
scope_body_expr = new_scope_body_expr;
};
})
new_scope_body_expr new_scope_next
let program_map
(t : 'a -> 'm expr -> (dcalc, 'm mark) boxed_gexpr)
(ctx : 'a)
(p : 'm program) : 'm program Bindlib.box =
Bindlib.box_apply
(fun new_scopes -> { p with scopes = new_scopes })
(scopes_map t ctx p.scopes)
let optimize_program (p : 'm program) : 'm program =
Bindlib.unbox
(program_map partial_evaluation
{ var_values = Var.Map.empty; decl_ctx = p.decl_ctx }
(Program.map_exprs
~f:
(partial_evaluation
{ var_values = Var.Map.empty; decl_ctx = p.decl_ctx })
~varf:(fun v -> v)
p)

62
compiler/desugared/ast.ml
View File

@ -103,7 +103,7 @@ type rule = {
rule_id : RuleName.t;
rule_just : expr boxed;
rule_cons : expr boxed;
rule_parameter : (expr Var.t * typ) option;
rule_parameter : (expr Var.t * typ) list option;
rule_exception : exception_situation;
rule_label : label_situation;
}
@ -124,45 +124,46 @@ module Rule = struct
let c2 = Expr.unbox r2.rule_cons in
Expr.compare c1 c2
| n -> n)
| Some (v1, t1), Some (v2, t2) -> (
match Type.compare t1 t2 with
| 0 -> (
let open Bindlib in
let b1 = unbox (bind_var v1 (Expr.Box.lift r1.rule_just)) in
let b2 = unbox (bind_var v2 (Expr.Box.lift r2.rule_just)) in
let _, j1, j2 = unbind2 b1 b2 in
match Expr.compare j1 j2 with
| 0 ->
let b1 = unbox (bind_var v1 (Expr.Box.lift r1.rule_cons)) in
let b2 = unbox (bind_var v2 (Expr.Box.lift r2.rule_cons)) in
let _, c1, c2 = unbind2 b1 b2 in
Expr.compare c1 c2
| n -> n)
| n -> n)
| Some l1, Some l2 ->
ListLabels.compare l1 l2 ~cmp:(fun (v1, t1) (v2, t2) ->
match Type.compare t1 t2 with
| 0 -> (
let open Bindlib in
let b1 = unbox (bind_var v1 (Expr.Box.lift r1.rule_just)) in
let b2 = unbox (bind_var v2 (Expr.Box.lift r2.rule_just)) in
let _, j1, j2 = unbind2 b1 b2 in
match Expr.compare j1 j2 with
| 0 ->
let b1 = unbox (bind_var v1 (Expr.Box.lift r1.rule_cons)) in
let b2 = unbox (bind_var v2 (Expr.Box.lift r2.rule_cons)) in
let _, c1, c2 = unbind2 b1 b2 in
Expr.compare c1 c2
| n -> n)
| n -> n)
| None, Some _ -> -1
| Some _, None -> 1
end
let empty_rule (pos : Pos.t) (have_parameter : typ option) : rule =
let empty_rule (pos : Pos.t) (have_parameter : typ list option) : rule =
{
rule_just = Expr.box (ELit (LBool false), Untyped { pos });
rule_cons = Expr.box (ELit LEmptyError, Untyped { pos });
rule_parameter =
(match have_parameter with
| Some typ -> Some (Var.make "dummy", typ)
| Some typs -> Some (List.map (fun typ -> Var.make "dummy", typ) typs)
| None -> None);
rule_exception = BaseCase;
rule_id = RuleName.fresh ("empty", pos);
rule_label = Unlabeled;
}
let always_false_rule (pos : Pos.t) (have_parameter : typ option) : rule =
let always_false_rule (pos : Pos.t) (have_parameter : typ list option) : rule =
{
rule_just = Expr.box (ELit (LBool true), Untyped { pos });
rule_cons = Expr.box (ELit (LBool false), Untyped { pos });
rule_parameter =
(match have_parameter with
| Some typ -> Some (Var.make "dummy", typ)
| Some typs -> Some (List.map (fun typ -> Var.make "dummy", typ) typs)
| None -> None);
rule_exception = BaseCase;
rule_id = RuleName.fresh ("always_false", pos);
@ -197,6 +198,7 @@ type scope = {
type program = {
program_scopes : scope ScopeName.Map.t;
program_topdefs : (expr * typ) TopdefName.Map.t;
program_ctx : decl_ctx;
}
@ -216,15 +218,19 @@ let free_variables (def : rule RuleName.Map.t) : Pos.t ScopeDefMap.t =
Pos.t ScopeDefMap.t =
LocationSet.fold
(fun (loc, loc_pos) acc ->
ScopeDefMap.add
(match loc with
| DesugaredScopeVar (v, st) -> ScopeDef.Var (Marked.unmark v, st)
let usage =
match loc with
| DesugaredScopeVar (v, st) ->
Some (ScopeDef.Var (Marked.unmark v, st))
| SubScopeVar (_, sub_index, sub_var) ->
ScopeDef.SubScopeVar
( Marked.unmark sub_index,
Marked.unmark sub_var,
Marked.get_mark sub_index ))
loc_pos acc)
Some
(ScopeDef.SubScopeVar
( Marked.unmark sub_index,
Marked.unmark sub_var,
Marked.get_mark sub_index ))
| ToplevelVar _ -> None
in
match usage with Some u -> ScopeDefMap.add u loc_pos acc | None -> acc)
locs acc
in
RuleName.Map.fold

7
compiler/desugared/ast.mli
View File

@ -60,15 +60,15 @@ type rule = {
rule_id : RuleName.t;
rule_just : expr boxed;
rule_cons : expr boxed;
rule_parameter : (expr Var.t * typ) option;
rule_parameter : (expr Var.t * typ) list option;
rule_exception : exception_situation;
rule_label : label_situation;
}
module Rule : Set.OrderedType with type t = rule
val empty_rule : Pos.t -> typ option -> rule
val always_false_rule : Pos.t -> typ option -> rule
val empty_rule : Pos.t -> typ list option -> rule
val always_false_rule : Pos.t -> typ list option -> rule
type assertion = expr boxed
type variation_typ = Increasing | Decreasing
@ -119,6 +119,7 @@ type scope = {
type program = {
program_scopes : scope ScopeName.Map.t;
program_topdefs : (expr * typ) TopdefName.Map.t;
program_ctx : decl_ctx;
}

58
compiler/desugared/dependency.ml
View File

@ -41,15 +41,24 @@ module Vertex = struct
| Var (x, Some sx) -> Int.logxor (ScopeVar.hash x) (StateName.hash sx)
| SubScope x -> SubScopeName.hash x
let compare = compare
let compare x y =
match x, y with
| Var (x, xst), Var (y, yst) -> (
match ScopeVar.compare x y with
| 0 -> Option.compare StateName.compare xst yst
| n -> n)
| SubScope x, SubScope y -> SubScopeName.compare x y
| Var _, _ -> -1
| _, Var _ -> 1
| SubScope _, _ -> .
| _, SubScope _ -> .
let equal x y =
match x, y with
| Var (x, None), Var (y, None) -> ScopeVar.compare x y = 0
| Var (x, Some sx), Var (y, Some sy) ->
ScopeVar.compare x y = 0 && StateName.compare sx sy = 0
| SubScope x, SubScope y -> SubScopeName.compare x y = 0
| _ -> false
| Var (x, sx), Var (y, sy) ->
ScopeVar.equal x y && Option.equal StateName.equal sx sy
| SubScope x, SubScope y -> SubScopeName.equal x y
| (Var _ | SubScope _), _ -> false
let format_t (fmt : Format.formatter) (x : t) : unit =
match x with
@ -57,6 +66,11 @@ module Vertex = struct
| Var (v, Some sv) ->
Format.fprintf fmt "%a.%a" ScopeVar.format_t v StateName.format_t sv
| SubScope v -> SubScopeName.format_t fmt v
let info = function
| Var (v, None) -> ScopeVar.get_info v
| Var (_, Some sv) -> StateName.get_info sv
| SubScope v -> SubScopeName.get_info v
end
(** On the edges, the label is the position of the expression responsible for
@ -97,32 +111,13 @@ let check_for_cycle (scope : Ast.scope) (g : ScopeDependencies.t) : unit =
List.flatten
(List.map
(fun v ->
let var_str, var_info =
match v with
| Vertex.Var (v, None) ->
Format.asprintf "%a" ScopeVar.format_t v, ScopeVar.get_info v
| Vertex.Var (v, Some sv) ->
( Format.asprintf "%a.%a" ScopeVar.format_t v
StateName.format_t sv,
StateName.get_info sv )
| Vertex.SubScope v ->
( Format.asprintf "%a" SubScopeName.format_t v,
SubScopeName.get_info v )
in
let var_str = Format.asprintf "%a" Vertex.format_t v in
let var_info = Vertex.info v in
let succs = ScopeDependencies.succ_e g v in
let _, edge_pos, succ =
List.find (fun (_, _, succ) -> List.mem succ scc) succs
in
let succ_str =
match succ with
| Vertex.Var (v, None) ->
Format.asprintf "%a" ScopeVar.format_t v
| Vertex.Var (v, Some sv) ->
Format.asprintf "%a.%a" ScopeVar.format_t v StateName.format_t
sv
| Vertex.SubScope v ->
Format.asprintf "%a" SubScopeName.format_t v
in
let succ_str = Format.asprintf "%a" Vertex.format_t succ in
[
( Some ("Cycle variable " ^ var_str ^ ", declared:"),
Marked.get_mark var_info );
@ -171,7 +166,10 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
| ( Ast.ScopeDef.Var (v_defined, s_defined),
Ast.ScopeDef.Var (v_used, s_used) ) ->
(* simple case *)
if v_used = v_defined && s_used = s_defined then
if
ScopeVar.equal v_used v_defined
&& Option.equal StateName.equal s_used s_defined
then
(* variable definitions cannot be recursive *)
Errors.raise_spanned_error fv_def_pos
"The variable %a is used in one of its definitions, but \
@ -199,7 +197,7 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
Ast.ScopeDef.SubScopeVar (used, _, _) ) ->
(* here we are defining the input of a scope with the output of
another subscope *)
if used = defined then
if SubScopeName.equal used defined then
(* subscopes are not recursive functions *)
Errors.raise_spanned_error fv_def_pos
"The subscope %a is used when defining one of its inputs, \

18
compiler/desugared/disambiguate.ml
View File

@ -29,7 +29,9 @@ let rule ctx env rule =
let env =
match rule.rule_parameter with
| None -> env
| Some (v, ty) -> Typing.Env.add_var v ty env
| Some vars_and_types ->
ListLabels.fold_right vars_and_types ~init:env ~f:(fun (v, t) ->
Typing.Env.add_var v t)
in
(* Note: we could use the known rule type here to direct typing. We choose not
to because it shouldn't be needed for disambiguation, and we prefer to
@ -58,6 +60,16 @@ let scope ctx env scope =
{ scope with scope_defs; scope_assertions }
let program prg =
let env =
TopdefName.Map.fold
(fun name (_e, ty) env -> Typing.Env.add_toplevel_var name ty env)
prg.program_topdefs Typing.Env.empty
in
let program_topdefs =
TopdefName.Map.map
(fun (e, ty) -> Expr.unbox (expr prg.program_ctx env (Expr.box e)), ty)
prg.program_topdefs
in
let env =
ScopeName.Map.fold
(fun scope_name scope env ->
@ -70,9 +82,9 @@ let program prg =
scope.scope_defs ScopeVar.Map.empty
in
Typing.Env.add_scope scope_name ~vars env)
prg.program_scopes Typing.Env.empty
prg.program_scopes env
in
let program_scopes =
ScopeName.Map.map (scope prg.program_ctx env) prg.program_scopes
in
{ prg with program_scopes }
{ prg with program_topdefs; program_scopes }

121
compiler/desugared/from_surface.ml
View File

@ -192,13 +192,18 @@ let rec check_formula (op, pos_op) e =
(** Usage: [translate_expr scope ctxt naked_expr]
Translates [expr] into its desugared equivalent. [scope] is used to
disambiguate the scope and subscopes variables than occur in the expression *)
disambiguate the scope and subscopes variables than occur in the expression,
[None] is assumed to mean a toplevel definition *)
let rec translate_expr
(scope : ScopeName.t)
(scope : ScopeName.t option)
(inside_definition_of : Ast.ScopeDef.t Marked.pos option)
(ctxt : Name_resolution.context)
(expr : Surface.Ast.expression) : Ast.expr boxed =
let scope_ctxt = ScopeName.Map.find scope ctxt.scopes in
let scope_vars =
match scope with
| None -> IdentName.Map.empty
| Some s -> (ScopeName.Map.find s ctxt.scopes).var_idmap
in
let rec_helper = translate_expr scope inside_definition_of ctxt in
let pos = Marked.get_mark expr in
let emark = Untyped { pos } in
@ -299,10 +304,13 @@ let rec translate_expr
Expr.elit lit emark
| Ident ([], (x, pos)) -> (
(* first we check whether this is a local var, then we resort to scope-wide
variables *)
variables, then global variables *)
match IdentName.Map.find_opt x ctxt.local_var_idmap with
| Some uid ->
Expr.make_var uid emark
(* the whole box thing is to accomodate for this case *)
| None -> (
match IdentName.Map.find_opt x scope_ctxt.var_idmap with
match IdentName.Map.find_opt x scope_vars with
| Some (ScopeVar uid) ->
(* If the referenced variable has states, then here are the rules to
desambiguate. In general, only the last state can be referenced.
@ -343,21 +351,28 @@ let rec translate_expr
Some (List.hd (List.rev states)))
in
Expr.elocation (DesugaredScopeVar ((uid, pos), x_state)) emark
| Some (SubScope _) | None ->
Name_resolution.raise_unknown_identifier
"for a local or scope-wide variable" (x, pos))
| Some uid ->
Expr.make_var uid emark
(* the whole box thing is to accomodate for this case *))
| 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 *)
| None -> (
match IdentName.Map.find_opt x ctxt.topdefs with
| Some v ->
Expr.elocation
(ToplevelVar (v, Marked.get_mark (TopdefName.get_info v)))
emark
| None ->
Name_resolution.raise_unknown_identifier
"for a local, scope-wide or global variable" (x, pos))))
| Ident (_path, _x) ->
Errors.raise_spanned_error pos "Qualified paths are not supported yet"
| Dotted (e, ((path, x), _ppos)) -> (
match path, Marked.unmark e with
| [], Ident ([], (y, _)) when Name_resolution.is_subscope_uid scope ctxt y
->
| [], Ident ([], (y, _))
when Option.fold scope ~none:false ~some:(fun s ->
Name_resolution.is_subscope_uid s ctxt y) ->
(* In this case, y.x is a subscope variable *)
let subscope_uid, subscope_real_uid =
match IdentName.Map.find y scope_ctxt.var_idmap with
match IdentName.Map.find y scope_vars with
| SubScope (sub, sc) -> sub, sc
| ScopeVar _ -> assert false
in
@ -383,8 +398,12 @@ let rec translate_expr
Errors.raise_spanned_error pos "Qualified paths are not supported yet"
in
Expr.edstructaccess e (Marked.unmark x) str emark)
| FunCall (f, arg) -> Expr.eapp (rec_helper f) [rec_helper arg] emark
| FunCall (f, args) ->
Expr.eapp (rec_helper f) (List.map rec_helper args) emark
| ScopeCall ((([], sc_name), _), fields) ->
if scope = None then
Errors.raise_spanned_error pos
"Scope calls are not allowed outside of a scope";
let called_scope = Name_resolution.get_scope ctxt sc_name in
let scope_def = ScopeName.Map.find called_scope ctxt.scopes in
let in_struct =
@ -739,7 +758,7 @@ let rec translate_expr
| Builtin LastDayOfMonth -> Expr.eop LastDayOfMonth [TLit TDate, pos] emark
and disambiguate_match_and_build_expression
(scope : ScopeName.t)
(scope : ScopeName.t option)
(inside_definition_of : Ast.ScopeDef.t Marked.pos option)
(ctxt : Name_resolution.context)
(cases : Surface.Ast.match_case Marked.pos list) :
@ -906,11 +925,11 @@ let process_default
(cons : Surface.Ast.expression) : Ast.rule =
let just =
match just with
| Some just -> Some (translate_expr scope (Some def_key) ctxt just)
| Some just -> Some (translate_expr (Some scope) (Some def_key) ctxt just)
| None -> None
in
let just = merge_conditions precond just (Marked.get_mark def_key) in
let cons = translate_expr scope (Some def_key) ctxt cons in
let cons = translate_expr (Some scope) (Some def_key) ctxt cons in
{
rule_just = just;
rule_cons = cons;
@ -919,7 +938,12 @@ let process_default
Name_resolution.get_def_typ ctxt (Marked.unmark def_key)
in
match Marked.unmark def_key_typ, param_uid with
| TArrow (t_in, _), Some param_uid -> Some (Marked.unmark param_uid, t_in)
| TArrow ([t_in], _), Some param_uid ->
Some [Marked.unmark param_uid, t_in]
| TArrow _, Some _ ->
Errors.raise_spanned_error (Expr.pos cons)
"This definition has a function type but there is multiple \
arguments."
| TArrow _, None ->
Errors.raise_spanned_error (Expr.pos cons)
"This definition has a function type but the parameter is missing"
@ -1037,7 +1061,7 @@ let process_assert
(ass : Surface.Ast.assertion) : Ast.program =
let scope : Ast.scope = ScopeName.Map.find scope_uid prgm.program_scopes in
let ass =
translate_expr scope_uid None ctxt
translate_expr (Some scope_uid) None ctxt
(match ass.Surface.Ast.assertion_condition with
| None -> ass.Surface.Ast.assertion_content
| Some cond ->
@ -1071,7 +1095,7 @@ let process_scope_use_item
(ctxt : Name_resolution.context)
(prgm : Ast.program)
(item : Surface.Ast.scope_use_item Marked.pos) : Ast.program =
let precond = Option.map (translate_expr scope None ctxt) precond in
let precond = Option.map (translate_expr (Some scope) None ctxt) precond in
match Marked.unmark item with
| Surface.Ast.Rule rule -> process_rule precond scope ctxt prgm rule
| Surface.Ast.Definition def -> process_def precond scope ctxt prgm def
@ -1146,6 +1170,55 @@ let process_scope_use
(process_scope_use_item precond scope_uid ctxt)
prgm use.scope_use_items
let process_topdef
(ctxt : Name_resolution.context)
(prgm : Ast.program)
(def : S.top_def) : Ast.program =
let id =
IdentName.Map.find
(Marked.unmark def.S.topdef_name)
ctxt.Name_resolution.topdefs
in
let ty_pos = Marked.get_mark def.S.topdef_type in
let translate_typ t =
(* Todo: better helper function from a more appropriate place *)
Name_resolution.process_base_typ ctxt
(S.Data (Marked.unmark t), Marked.get_mark t)
in
let body_type = translate_typ def.S.topdef_type in
let arg_types =
List.map (fun (_, ty) -> translate_typ ty) def.S.topdef_args
in
let expr =
let ctxt, rv_args =
List.fold_left
(fun (ctxt, rv_args) (v, _ty) ->
let ctxt, a =
Name_resolution.add_def_local_var ctxt (Marked.unmark v)
in
ctxt, a :: rv_args)
(ctxt, []) def.S.topdef_args
in
let body = translate_expr None None ctxt def.S.topdef_expr in
match rv_args with
| [] -> body
| rv_args ->
Expr.make_abs
(Array.of_list (List.rev rv_args))
body arg_types
(Marked.get_mark def.S.topdef_name)
in
let typ =
match arg_types with
| [] -> body_type
| _ -> TArrow (arg_types, body_type), ty_pos
in
{
prgm with
Ast.program_topdefs =
TopdefName.Map.add id (Expr.unbox expr, typ) prgm.Ast.program_topdefs;
}
let attribute_to_io (attr : Surface.Ast.scope_decl_context_io) : Ast.io =
{
Ast.io_output = attr.scope_decl_context_io_output;
@ -1294,6 +1367,7 @@ let translate_program
ctxt.Name_resolution.typedefs ScopeName.Map.empty;
ctx_struct_fields = ctxt.Name_resolution.field_idmap;
};
Ast.program_topdefs = TopdefName.Map.empty;
Ast.program_scopes;
}
in
@ -1310,7 +1384,10 @@ let translate_program
(fun prgm item ->
match Marked.unmark item with
| Surface.Ast.ScopeUse use -> process_scope_use ctxt prgm use
| _ -> prgm)
| Surface.Ast.Topdef def -> process_topdef ctxt prgm def
| Surface.Ast.ScopeDecl _ | Surface.Ast.StructDecl _
| Surface.Ast.EnumDecl _ ->
prgm)
prgm block
| LawInclude _ | LawText _ -> prgm
in

18
compiler/desugared/name_resolution.ml
View File

@ -81,6 +81,7 @@ type context = {
(** The names of the enum constructors. Constructor names can be shared
between different enums *)
scopes : scope_context ScopeName.Map.t; (** For each scope, its context *)
topdefs : TopdefName.t IdentName.Map.t; (** Global definitions *)
structs : struct_context StructName.Map.t;
(** For each struct, its context *)
enums : enum_context EnumName.Map.t; (** For each enum, its context *)
@ -318,7 +319,9 @@ let process_type (ctxt : context) ((naked_typ, typ_pos) : Surface.Ast.typ) : typ
match naked_typ with
| Surface.Ast.Base base_typ -> process_base_typ ctxt (base_typ, typ_pos)
| Surface.Ast.Func { arg_typ; return_typ } ->
( TArrow (process_base_typ ctxt arg_typ, process_base_typ ctxt return_typ),
(* TODO Louis: /!\ There is only one argument in the surface syntax for
function now. *)
( TArrow ([process_base_typ ctxt arg_typ], process_base_typ ctxt return_typ),
typ_pos )
(** Process data declaration *)
@ -638,6 +641,15 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
(TEnum e_uid) ctxt.typedefs;
}
| ScopeUse _ -> ctxt
| Topdef def ->
let name, pos = def.topdef_name in
Option.iter
(fun use ->
raise_already_defined_error (TopdefName.get_info use) name pos
"toplevel definition")
(IdentName.Map.find_opt name ctxt.topdefs);
let uid = TopdefName.fresh def.topdef_name in
{ ctxt with topdefs = IdentName.Map.add name uid ctxt.topdefs }
(** Process a code item that is a declaration *)
let process_decl_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
@ -647,6 +659,7 @@ let process_decl_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
| StructDecl sdecl -> process_struct_decl ctxt sdecl
| EnumDecl edecl -> process_enum_decl ctxt edecl
| ScopeUse _ -> ctxt
| Topdef _ -> ctxt
(** Process a code block *)
let process_code_block
@ -865,7 +878,7 @@ let process_scope_use (ctxt : context) (suse : Surface.Ast.scope_use) : context
let process_use_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
: context =
match Marked.unmark item with
| ScopeDecl _ | StructDecl _ | EnumDecl _ -> ctxt
| ScopeDecl _ | StructDecl _ | EnumDecl _ | Topdef _ -> ctxt
| ScopeUse suse -> process_scope_use ctxt suse
(** {1 API} *)
@ -877,6 +890,7 @@ let form_context (prgm : Surface.Ast.program) : context =
local_var_idmap = IdentName.Map.empty;
typedefs = IdentName.Map.empty;
scopes = ScopeName.Map.empty;
topdefs = IdentName.Map.empty;
var_typs = ScopeVar.Map.empty;
structs = StructName.Map.empty;
field_idmap = IdentName.Map.empty;

5
compiler/desugared/name_resolution.mli
View File

@ -81,6 +81,7 @@ type context = {
(** The names of the enum constructors. Constructor names can be shared
between different enums *)
scopes : scope_context ScopeName.Map.t; (** For each scope, its context *)
topdefs : TopdefName.t IdentName.Map.t; (** Global definitions *)
structs : struct_context StructName.Map.t;
(** For each struct, its context *)
enums : enum_context EnumName.Map.t; (** For each enum, its context *)
@ -149,6 +150,10 @@ val get_scope : context -> IdentName.t Marked.pos -> ScopeName.t
(** Find a scope definition from the typedefs, failing if there is none or it
has a different kind *)
val process_base_typ : context -> Surface.Ast.base_typ Marked.pos -> typ
(** Convert a surface base type to an AST type *)
(* Note: should probably be moved to a different module *)
(** {1 API} *)
val form_context : Surface.Ast.program -> context

35
compiler/driver.ml
View File

@ -237,14 +237,13 @@ let driver source_file (options : Cli.options) : int =
( scope_uid,
Option.get
(Shared_ast.Scope.fold_left ~init:None
~f:(fun acc scope_def _ ->
if
Shared_ast.ScopeName.compare scope_def.scope_name
scope_uid
= 0
then Some scope_def.scope_body
else acc)
prgm.scopes) )
~f:(fun acc def _ ->
match def with
| ScopeDef (name, body)
when Shared_ast.ScopeName.equal name scope_uid ->
Some body
| _ -> acc)
prgm.code_items) )
else
let prgrm_dcalc_expr =
Shared_ast.Expr.unbox (Shared_ast.Program.to_expr prgm scope_uid)
@ -357,7 +356,7 @@ let driver source_file (options : Cli.options) : int =
p.Plugin.apply ~source_file ~output_file ~scope:options.ex_scope
prgm type_ordering
| (`Python | `Scalc | `Plugin (Plugin.Scalc _)) as backend -> (
let prgm = Scalc.Compile_from_lambda.translate_program prgm in
let prgm = Scalc.From_lcalc.translate_program prgm in
match backend with
| `Scalc ->
let _output_file, with_output = get_output_format () in
@ -365,19 +364,15 @@ let driver source_file (options : Cli.options) : int =
@@ fun fmt ->
if Option.is_some options.ex_scope then
Format.fprintf fmt "%a\n"
(Scalc.Print.format_scope ~debug:options.debug
(Scalc.Print.format_item ~debug:options.debug
prgm.decl_ctx)
(List.find
(fun body ->
body.Scalc.Ast.scope_body_name = scope_uid)
prgm.scopes)
else
Format.fprintf fmt "%a\n"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(fun fmt scope ->
(Scalc.Print.format_scope prgm.decl_ctx) fmt scope))
prgm.scopes
(function
| Scalc.Ast.SScope { scope_body_name; _ } ->
scope_body_name = scope_uid
| _ -> false)
prgm.code_items)
else Scalc.Print.format_program prgm.decl_ctx fmt prgm
| `Python ->
let output_file, with_output =
get_output_format ~ext:".py" ()

92
compiler/lcalc/closure_conversion.ml
View File

@ -166,53 +166,49 @@ let closure_conversion_expr (type m) (ctx : m ctx) (e : m expr) : m expr boxed =
e'
let closure_conversion (p : 'm program) : 'm program Bindlib.box =
let new_scopes, _ =
Scope.fold_left
~f:(fun (acc_new_scopes, global_vars) scope scope_var ->
(* [acc_new_scopes] represents what has been translated in the past, it
needs a continuation to attach the rest of the translated scopes. *)
let scope_input_var, scope_body_expr =
Bindlib.unbind scope.scope_body.scope_body_expr
in
let global_vars = Var.Set.add scope_var global_vars in
let ctx =
{
name_context = Marked.unmark (ScopeName.get_info scope.scope_name);
globally_bound_vars = global_vars;
}
in
let new_scope_lets =
Scope.map_exprs_in_lets
~f:(closure_conversion_expr ctx)
~varf:(fun v -> v)
scope_body_expr
in
let new_scope_body_expr =
Bindlib.bind_var scope_input_var new_scope_lets
in
( (fun next ->
acc_new_scopes
(Bindlib.box_apply2
(fun new_scope_body_expr next ->
ScopeDef
{
scope with
scope_body =
{
scope.scope_body with
scope_body_expr = new_scope_body_expr;
};
scope_next = next;
})
new_scope_body_expr
(Bindlib.bind_var scope_var next))),
global_vars ))
~init:
( Fun.id,
Var.Set.of_list
(List.map Var.translate [handle_default; handle_default_opt]) )
p.scopes
let _, new_code_items =
Scope.fold_map
~f:(fun toplevel_vars var code_item ->
( Var.Set.add var toplevel_vars,
match code_item with
| ScopeDef (name, body) ->
let scope_input_var, scope_body_expr =
Bindlib.unbind body.scope_body_expr
in
let ctx =
{
name_context = Marked.unmark (ScopeName.get_info name);
globally_bound_vars = toplevel_vars;
}
in
let new_scope_lets =
Scope.map_exprs_in_lets
~f:(closure_conversion_expr ctx)
~varf:(fun v -> v)
scope_body_expr
in
let new_scope_body_expr =
Bindlib.bind_var scope_input_var new_scope_lets
in
Bindlib.box_apply
(fun scope_body_expr ->
ScopeDef (name, { body with scope_body_expr }))
new_scope_body_expr
| Topdef (name, ty, expr) ->
let ctx =
{
name_context = Marked.unmark (TopdefName.get_info name);
globally_bound_vars = toplevel_vars;
}
in
Bindlib.box_apply
(fun e -> Topdef (name, ty, e))
(Expr.Box.lift (closure_conversion_expr ctx expr)) ))
~varf:(fun v -> v)
(Var.Set.of_list
(List.map Var.translate [handle_default; handle_default_opt]))
p.code_items
in
Bindlib.box_apply
(fun new_scopes -> { p with scopes = new_scopes })
(new_scopes (Bindlib.box Nil))
(fun new_code_items -> { p with code_items = new_code_items })
new_code_items

110
compiler/lcalc/compile_with_exceptions.ml
View File

@ -19,9 +19,10 @@ open Shared_ast
module D = Dcalc.Ast
module A = Ast
type 'm ctx = ('m D.expr, 'm A.expr Var.t) Var.Map.t
(** This environment contains a mapping between the variables in Dcalc and their
correspondance in Lcalc. *)
type 'm ctx = unit
(** This translation no longer needs a context at the moment, but we keep
passing the argument through the functions in case the need arises with
further evolutions. *)
let thunk_expr (type m) (e : m A.expr boxed) : m A.expr boxed =
let dummy_var = Var.make "_" in
@ -29,6 +30,8 @@ let thunk_expr (type m) (e : m A.expr boxed) : m A.expr boxed =
let arg_t = Marked.mark pos (TLit TUnit) in
Expr.make_abs [| dummy_var |] e [arg_t] pos
let translate_var : 'm D.expr Var.t -> 'm A.expr Var.t = Var.translate
let rec translate_default
(ctx : 'm ctx)
(exceptions : 'm D.expr list)
@ -56,11 +59,14 @@ let rec translate_default
and translate_expr (ctx : 'm ctx) (e : 'm D.expr) : 'm A.expr boxed =
let m = Marked.get_mark e in
match Marked.unmark e with
| EVar v -> Expr.make_var (Var.Map.find v ctx) m
| EVar v -> Expr.make_var (translate_var v) m
| EStruct { name; fields } ->
Expr.estruct name (StructField.Map.map (translate_expr ctx) fields) m
| EStructAccess { name; e; field } ->
Expr.estructaccess (translate_expr ctx e) field name m
| ETuple es -> Expr.etuple (List.map (translate_expr ctx) es) m
| ETupleAccess { e; index; size } ->
Expr.etupleaccess (translate_expr ctx e) index size m
| EInj { name; e; cons } -> Expr.einj (translate_expr ctx e) cons name m
| EMatch { name; e; cases } ->
Expr.ematch (translate_expr ctx e) name
@ -88,16 +94,8 @@ and translate_expr (ctx : 'm ctx) (e : 'm D.expr) : 'm A.expr boxed =
(Marked.get_mark e)
| EAbs { binder; tys } ->
let vars, body = Bindlib.unmbind binder in
let ctx, lc_vars =
Array.fold_right
(fun var (ctx, lc_vars) ->
let lc_var = Var.make (Bindlib.name_of var) in
Var.Map.add var lc_var ctx, lc_var :: lc_vars)
vars (ctx, [])
in
let lc_vars = Array.of_list lc_vars in
let new_body = translate_expr ctx body in
let new_binder = Expr.bind lc_vars new_body in
let new_binder = Expr.bind (Array.map translate_var vars) new_body in
Expr.eabs new_binder tys (Marked.get_mark e)
| EDefault { excepts = [exn]; just; cons } when !Cli.optimize_flag ->
(* FIXME: bad place to rely on a global flag *)
@ -118,14 +116,14 @@ let rec translate_scope_lets
| Result e ->
Bindlib.box_apply (fun e -> Result e) (Expr.Box.lift (translate_expr ctx e))
| ScopeLet scope_let ->
let old_scope_let_var, scope_let_next =
let scope_let_var, scope_let_next =
Bindlib.unbind scope_let.scope_let_next
in
let new_scope_let_var = Var.make (Bindlib.name_of old_scope_let_var) in
let new_scope_let_expr = translate_expr ctx scope_let.scope_let_expr in
let new_ctx = Var.Map.add old_scope_let_var new_scope_let_var ctx in
let new_scope_next = translate_scope_lets decl_ctx new_ctx scope_let_next in
let new_scope_next = Bindlib.bind_var new_scope_let_var new_scope_next in
let new_scope_next = translate_scope_lets decl_ctx ctx scope_let_next in
let new_scope_next =
Bindlib.bind_var (translate_var scope_let_var) new_scope_next
in
Bindlib.box_apply2
(fun new_scope_next new_scope_let_expr ->
ScopeLet
@ -139,58 +137,38 @@ let rec translate_scope_lets
new_scope_next
(Expr.Box.lift new_scope_let_expr)
let rec translate_scopes
let translate_items
(decl_ctx : decl_ctx)
(ctx : 'm ctx)
(scopes : 'm D.expr scopes) : 'm A.expr scopes Bindlib.box =
match scopes with
| Nil -> Bindlib.box Nil
| ScopeDef scope_def ->
let old_scope_var, scope_next = Bindlib.unbind scope_def.scope_next in
let new_scope_var =
Var.make (Marked.unmark (ScopeName.get_info scope_def.scope_name))
in
let old_scope_input_var, scope_body_expr =
Bindlib.unbind scope_def.scope_body.scope_body_expr
in
let new_scope_input_var = Var.make (Bindlib.name_of old_scope_input_var) in
let new_ctx = Var.Map.add old_scope_input_var new_scope_input_var ctx in
let new_scope_body_expr =
translate_scope_lets decl_ctx new_ctx scope_body_expr
in
let new_scope_body_expr =
Bindlib.bind_var new_scope_input_var new_scope_body_expr
in
let new_scope : 'm A.expr scope_body Bindlib.box =
Bindlib.box_apply
(fun new_scope_body_expr ->
{
scope_body_input_struct =
scope_def.scope_body.scope_body_input_struct;
scope_body_output_struct =
scope_def.scope_body.scope_body_output_struct;
scope_body_expr = new_scope_body_expr;
})
new_scope_body_expr
in
let new_ctx = Var.Map.add old_scope_var new_scope_var new_ctx in
let scope_next =
Bindlib.bind_var new_scope_var
(translate_scopes decl_ctx new_ctx scope_next)
in
Bindlib.box_apply2
(fun new_scope scope_next ->
ScopeDef
{
scope_name = scope_def.scope_name;
scope_body = new_scope;
scope_next;
})
new_scope scope_next
(scopes : 'm D.expr code_item_list) : 'm A.expr code_item_list Bindlib.box =
Scope.map_ctx
~f:
(fun ctx -> function
| Topdef (name, ty, e) ->
( ctx,
Bindlib.box_apply
(fun e -> Topdef (name, ty, e))
(Expr.Box.lift (translate_expr ctx e)) )
| ScopeDef (name, body) ->
let scope_input_var, body_expr =
Bindlib.unbind body.scope_body_expr
in
let new_scope_body_expr =
translate_scope_lets decl_ctx ctx body_expr
in
let new_body =
Bindlib.bind_var (translate_var scope_input_var) new_scope_body_expr
in
( ctx,
Bindlib.box_apply
(fun scope_body_expr ->
ScopeDef (name, { body with scope_body_expr }))
new_body ))
~varf:translate_var ctx scopes
let translate_program (prgm : 'm D.program) : 'm A.program =
{
scopes =
Bindlib.unbox (translate_scopes prgm.decl_ctx Var.Map.empty prgm.scopes);
code_items =
Bindlib.unbox (translate_items prgm.decl_ctx () prgm.code_items);
decl_ctx = prgm.decl_ctx;
}

78
compiler/lcalc/compile_without_exceptions.ml
View File

@ -129,8 +129,8 @@ let rec translate_typ (tau : typ) : typ =
| TAny -> TAny
| TArray ts -> TArray (translate_typ ts)
(* catala is not polymorphic *)
| TArrow ((TLit TUnit, _), t2) -> TOption (translate_typ t2)
| TArrow (t1, t2) -> TArrow (translate_typ t1, translate_typ t2)
| TArrow ([(TLit TUnit, _)], t2) -> TOption (translate_typ t2)
| TArrow (t1, t2) -> TArrow (List.map translate_typ t1, translate_typ t2)
end
(** [c = disjoint_union_maps cs] Compute the disjoint union of multiple maps.
@ -268,6 +268,19 @@ let rec translate_and_hoist (ctx : 'm ctx) (e : 'm D.expr) :
let e1', hoists = translate_and_hoist ctx e1 in
let e1' = Expr.estructaccess e1' field name mark in
e1', hoists
| ETuple es ->
let hoists, es' =
List.fold_left_map
(fun hoists e ->
let e, h = translate_and_hoist ctx e in
h :: hoists, e)
[] es
in
Expr.etuple es' mark, disjoint_union_maps (Expr.pos e) hoists
| ETupleAccess { e = e1; index; size } ->
let e1', hoists = translate_and_hoist ctx e1 in
let e1' = Expr.etupleaccess e1' index size mark in
e1', hoists
| EInj { name; e = e1; cons } ->
let e1', hoists = translate_and_hoist ctx e1 in
let e1' = Expr.einj e1' cons name mark in
@ -445,7 +458,7 @@ let rec translate_scope_let (ctx : 'm ctx) (lets : 'm D.expr scope_body_expr) :
thunked, then the variable is context. If it's not thunked, it's a
regular input. *)
match Marked.unmark typ with
| TArrow ((TLit TUnit, _), _) -> false
| TArrow ([(TLit TUnit, _)], _) -> false
| _ -> true)
| ScopeVarDefinition | SubScopeVarDefinition | CallingSubScope
| DestructuringSubScopeResults | Assertion ->
@ -498,39 +511,34 @@ let translate_scope_body
})
(Bindlib.bind_var v' (translate_scope_let ctx' lets))
let rec translate_scopes (ctx : 'm ctx) (scopes : 'm D.expr scopes) :
'm A.expr scopes Bindlib.box =
match scopes with
| Nil -> Bindlib.box Nil
| ScopeDef { scope_name; scope_body; scope_next } ->
let scope_var, next = Bindlib.unbind scope_next in
let vmark =
match Bindlib.unbind scope_body.scope_body_expr with
| _, (Result e | ScopeLet { scope_let_expr = e; _ }) -> Marked.get_mark e
in
let new_ctx = add_var vmark scope_var true ctx in
let new_scope_name =
(find ~info:"variable that was just created" scope_var new_ctx).var
in
let scope_pos = Marked.get_mark (ScopeName.get_info scope_name) in
let new_body = translate_scope_body scope_pos ctx scope_body in
let tail = translate_scopes new_ctx next in
Bindlib.box_apply2
(fun body tail ->
ScopeDef { scope_name; scope_body = body; scope_next = tail })
new_body
(Bindlib.bind_var new_scope_name tail)
let translate_code_items (ctx : 'm ctx) (scopes : 'm D.expr code_item_list) :
'm A.expr code_item_list Bindlib.box =
let _ctx, scopes =
Scope.fold_map
~f:
(fun ctx var -> function
| Topdef (name, ty, e) ->
( add_var (Marked.get_mark e) var true ctx,
Bindlib.box_apply
(fun e -> Topdef (name, ty, e))
(Expr.Box.lift (translate_expr ~append_esome:false ctx e)) )
| ScopeDef (scope_name, scope_body) ->
( ctx,
let scope_pos = Marked.get_mark (ScopeName.get_info scope_name) in
Bindlib.box_apply
(fun body -> ScopeDef (scope_name, body))
(translate_scope_body scope_pos ctx scope_body) ))
~varf:Var.translate ctx scopes
in
scopes
let translate_program (prgm : 'm D.program) : 'm A.program =
let inputs_structs =
Scope.fold_left prgm.scopes ~init:[] ~f:(fun acc scope_def _ ->
scope_def.scope_body.scope_body_input_struct :: acc)
Scope.fold_left prgm.code_items ~init:[] ~f:(fun acc def _ ->
match def with
| ScopeDef (_, body) -> body.scope_body_input_struct :: acc
| Topdef _ -> acc)
in
(* Cli.debug_print @@ Format.asprintf "List of structs to modify: [%a]"
(Format.pp_print_list D.StructName.format_t) inputs_structs; *)
let decl_ctx =
@ -557,9 +565,9 @@ let translate_program (prgm : 'm D.program) : 'm A.program =
}
in
let scopes =
let code_items =
Bindlib.unbox
(translate_scopes { decl_ctx; vars = Var.Map.empty } prgm.scopes)
(translate_code_items { decl_ctx; vars = Var.Map.empty } prgm.code_items)
in
{ scopes; decl_ctx }
{ code_items; decl_ctx }

18
compiler/lcalc/optimizations.ml
View File

@ -53,16 +53,20 @@ let rec beta_expr (e : 'm expr) : 'm expr boxed =
| _ -> visitor_map beta_expr e
let iota_optimizations (p : 'm program) : 'm program =
let new_scopes = Scope.map_exprs ~f:iota_expr ~varf:(fun v -> v) p.scopes in
{ p with scopes = Bindlib.unbox new_scopes }
let new_code_items =
Scope.map_exprs ~f:iota_expr ~varf:(fun v -> v) p.code_items
in
{ p with code_items = Bindlib.unbox new_code_items }
(* TODO: beta optimizations apply inlining of the program. We left the inclusion
of beta-optimization as future work since its produce code that is harder to
read, and can produce exponential blowup of the size of the generated
program. *)
let _beta_optimizations (p : 'm program) : 'm program =
let new_scopes = Scope.map_exprs ~f:beta_expr ~varf:(fun v -> v) p.scopes in
{ p with scopes = Bindlib.unbox new_scopes }
let new_code_items =
Scope.map_exprs ~f:beta_expr ~varf:(fun v -> v) p.code_items
in
{ p with code_items = Bindlib.unbox new_code_items }
let rec peephole_expr (e : 'm expr) : 'm expr boxed =
let m = Marked.get_mark e in
@ -95,10 +99,10 @@ let rec peephole_expr (e : 'm expr) : 'm expr boxed =
| _ -> visitor_map peephole_expr e
let peephole_optimizations (p : 'm program) : 'm program =
let new_scopes =
Scope.map_exprs ~f:peephole_expr ~varf:(fun v -> v) p.scopes
let new_code_items =
Scope.map_exprs ~f:peephole_expr ~varf:(fun v -> v) p.code_items
in
{ p with scopes = Bindlib.unbox new_scopes }
{ p with code_items = Bindlib.unbox new_code_items }
let optimize_program (p : 'm program) : untyped program =
p |> iota_optimizations |> peephole_optimizations |> Program.untype

47
compiler/lcalc/to_ocaml.ml
View File

@ -167,8 +167,11 @@ let rec format_typ (fmt : Format.formatter) (typ : typ) : unit =
format_enum_name Ast.option_enum
| TEnum e -> Format.fprintf fmt "%a.t" format_to_module_name (`Ename e)
| TArrow (t1, t2) ->
Format.fprintf fmt "@[<hov 2>%a ->@ %a@]" format_typ_with_parens t1
format_typ_with_parens t2
Format.fprintf fmt "@[<hov 2>%a@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " ->@ ")
format_typ_with_parens)
(t1 @ [t2])
| TArray t1 -> Format.fprintf fmt "@[%a@ array@]" format_typ_with_parens t1
| TAny -> Format.fprintf fmt "_"
@ -504,24 +507,27 @@ let rec format_scope_body_expr
(format_scope_body_expr ctx)
scope_let_next
let rec format_scopes
let format_code_items
(ctx : decl_ctx)
(fmt : Format.formatter)
(scopes : 'm Ast.expr scopes) : unit =
match scopes with
| Nil -> ()
| ScopeDef scope_def ->
let scope_input_var, scope_body_expr =
Bindlib.unbind scope_def.scope_body.scope_body_expr
in
let scope_var, scope_next = Bindlib.unbind scope_def.scope_next in
Format.fprintf fmt "@\n@\n@[<hov 2>let %a (%a: %a.t) : %a.t =@\n%a@]%a"
format_var scope_var format_var scope_input_var format_to_module_name
(`Sname scope_def.scope_body.scope_body_input_struct)
format_to_module_name
(`Sname scope_def.scope_body.scope_body_output_struct)
(format_scope_body_expr ctx)
scope_body_expr (format_scopes ctx) scope_next
(code_items : 'm Ast.expr code_item_list) : unit =
Scope.fold_left
~f:(fun () item var ->
match item with
| Topdef (_, typ, e) ->
Format.fprintf fmt "@\n@\n@[<hov 2>let %a : %a =@\n%a@]" format_var var
format_typ typ (format_expr ctx) e
| ScopeDef (_, body) ->
let scope_input_var, scope_body_expr =
Bindlib.unbind body.scope_body_expr
in
Format.fprintf fmt "@\n@\n@[<hov 2>let %a (%a: %a.t) : %a.t =@\n%a@]"
format_var var format_var scope_input_var format_to_module_name
(`Sname body.scope_body_input_struct) format_to_module_name
(`Sname body.scope_body_output_struct)
(format_scope_body_expr ctx)
scope_body_expr)
~init:() code_items
let format_program
(fmt : Format.formatter)
@ -538,5 +544,6 @@ let format_program
@\n\
%a%a@\n\
@?"
(format_ctx type_ordering) p.decl_ctx (format_scopes p.decl_ctx)
p.scopes)
(format_ctx type_ordering) p.decl_ctx
(format_code_items p.decl_ctx)
p.code_items)

100
compiler/plugins/api_web.ml
View File

@ -78,8 +78,11 @@ module To_jsoo = struct
Format.fprintf fmt "@[%a@ Js.js_array Js.t@]" format_typ_with_parens t1
| TAny -> Format.fprintf fmt "Js.Unsafe.any Js.t"
| TArrow (t1, t2) ->
Format.fprintf fmt "(@[<hov 2>%a, @ %a@]) Js.meth_callback"
format_typ_with_parens t1 format_typ_with_parens t2
Format.fprintf fmt "(@[<hov 2>unit, @ %a -> %a@]) Js.meth_callback"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.pp_print_string fmt " -> ")
format_typ_with_parens)
t1 format_typ_with_parens t2
let rec format_typ_to_jsoo fmt typ =
match Marked.unmark typ with
@ -153,13 +156,23 @@ module To_jsoo = struct
(fun fmt (struct_field, struct_field_type) ->
match Marked.unmark struct_field_type with
| TArrow (t1, t2) ->
let args_names =
ListLabels.mapi t1 ~f:(fun i _ ->
"function_input" ^ string_of_int i)
in
Format.fprintf fmt
"@[<hov 2>method %a =@ Js.wrap_meth_callback@ @[<hv 2>(@,\
fun input ->@ %a (%a.%a (%a input)))@]@]"
fun _ %a ->@ %a (%a.%a %a))@]@]"
format_struct_field_name_camel_case struct_field
(Format.pp_print_list (fun fmt (arg_i, ti) ->
Format.fprintf fmt "(%s: %a)" arg_i format_typ ti))
(List.combine args_names t1)
format_typ_to_jsoo t2 fmt_struct_name ()
format_struct_field_name (None, struct_field)
format_typ_of_jsoo t1
(Format.pp_print_list (fun fmt (i, ti) ->
Format.fprintf fmt "@[<hv 2>(%a@ %a)@]"
format_typ_of_jsoo ti Format.pp_print_string i))
(List.combine args_names t1)
| _ ->
Format.fprintf fmt "@[<hov 2>val %a =@ %a %a.%a@]"
format_struct_field_name_camel_case struct_field
@ -329,48 +342,49 @@ module To_jsoo = struct
Format.fprintf fmt "%a@\n" format_enum_decl (e, find_enum e ctx))
(type_ordering @ scope_structs)
let fmt_input_struct_name fmt (scope_def : 'a expr scope_def) =
format_struct_name fmt scope_def.scope_body.scope_body_input_struct
let fmt_input_struct_name fmt (scope_body : 'a expr scope_body) =
format_struct_name fmt scope_body.scope_body_input_struct
let fmt_output_struct_name fmt (scope_def : 'a expr scope_def) =
format_struct_name fmt scope_def.scope_body.scope_body_output_struct
let fmt_output_struct_name fmt (scope_body : 'a expr scope_body) =
format_struct_name fmt scope_body.scope_body_output_struct
let rec format_scopes_to_fun
(ctx : decl_ctx)
let format_scopes_to_fun
(_ctx : decl_ctx)
(fmt : Format.formatter)
(scopes : 'e scopes) =
match scopes with
| Nil -> ()
| ScopeDef scope_def ->
let scope_var, scope_next = Bindlib.unbind scope_def.scope_next in
let fmt_fun_call fmt _ =
Format.fprintf fmt "@[<hv>%a@ |> %a_of_jsoo@ |> %a@ |> %a_to_jsoo@]"
fmt_input_struct_name scope_def fmt_input_struct_name scope_def
format_var scope_var fmt_output_struct_name scope_def
in
Format.fprintf fmt
"@\n@\n@[<hov 2>let %a@ (%a : %a Js.t)@ : %a Js.t =@\n%a@]@\n%a"
format_var scope_var fmt_input_struct_name scope_def
fmt_input_struct_name scope_def fmt_output_struct_name scope_def
fmt_fun_call () (format_scopes_to_fun ctx) scope_next
(scopes : 'e code_item_list) =
Scope.fold_left
~f:(fun () code_item var ->
match code_item with
| Topdef _ -> ()
| ScopeDef (_name, body) ->
let fmt_fun_call fmt _ =
Format.fprintf fmt "@[<hv>%a@ |> %a_of_jsoo@ |> %a@ |> %a_to_jsoo@]"
fmt_input_struct_name body fmt_input_struct_name body format_var
var fmt_output_struct_name body
in
Format.fprintf fmt
"@\n@\n@[<hov 2>let %a@ (%a : %a Js.t)@ : %a Js.t =@\n%a@]@\n"
format_var var fmt_input_struct_name body fmt_input_struct_name body
fmt_output_struct_name body fmt_fun_call ())
~init:() scopes
let rec format_scopes_to_callbacks
(ctx : decl_ctx)
let format_scopes_to_callbacks
(_ctx : decl_ctx)
(fmt : Format.formatter)
(scopes : 'e scopes) : unit =
match scopes with
| Nil -> ()
| ScopeDef scope_def ->
let scope_var, scope_next = Bindlib.unbind scope_def.scope_next in
let fmt_meth_name fmt _ =
Format.fprintf fmt "method %a : (%a Js.t -> %a Js.t) Js.callback"
format_var_camel_case scope_var fmt_input_struct_name scope_def
fmt_output_struct_name scope_def
in
Format.fprintf fmt "@,@[<hov 2>%a =@ Js.wrap_callback@ %a@]@,%a"
fmt_meth_name () format_var scope_var
(format_scopes_to_callbacks ctx)
scope_next
(scopes : 'e code_item_list) : unit =
Scope.fold_left
~f:(fun () code_item var ->
match code_item with
| Topdef _ -> ()
| ScopeDef (_name, body) ->
let fmt_meth_name fmt _ =
Format.fprintf fmt "method %a : (%a Js.t -> %a Js.t) Js.callback"
format_var_camel_case var fmt_input_struct_name body
fmt_output_struct_name body
in
Format.fprintf fmt "@,@[<hov 2>%a =@ Js.wrap_callback@ %a@]@,"
fmt_meth_name () format_var var)
~init:() scopes
let format_program
(fmt : Format.formatter)
@ -411,9 +425,9 @@ module To_jsoo = struct
(Option.fold ~none:"" ~some:(fun name -> name) module_name)
(format_ctx type_ordering) prgm.decl_ctx
(format_scopes_to_fun prgm.decl_ctx)
prgm.scopes fmt_lib_name ()
prgm.code_items fmt_lib_name ()
(format_scopes_to_callbacks prgm.decl_ctx)
prgm.scopes)
prgm.code_items)
end
let apply

23
compiler/plugins/json_schema.ml
View File

@ -48,14 +48,15 @@ module To_json = struct
Format.fprintf fmt "%s" s
let rec find_scope_def (target_name : string) :
'm expr scopes -> 'm expr scope_def option = function
'm expr code_item_list -> (ScopeName.t * 'm expr scope_body) option =
function
| Nil -> None
| ScopeDef scope_def ->
let name = Format.asprintf "%a" ScopeName.format_t scope_def.scope_name in
if name = target_name then Some scope_def
else
let _, next_scope = Bindlib.unbind scope_def.scope_next in
find_scope_def target_name next_scope
| Cons (ScopeDef (name, body), _)
when String.equal target_name (Marked.unmark (ScopeName.get_info name)) ->
Some (name, body)
| Cons (_, next_bind) ->
let _, next_scope = Bindlib.unbind next_bind in
find_scope_def target_name next_scope
let fmt_tlit fmt (tlit : typ_lit) =
match tlit with
@ -101,7 +102,7 @@ module To_json = struct
let fmt_definitions
(ctx : decl_ctx)
(fmt : Format.formatter)
(scope_def : 'e scope_def) =
((_scope_name, scope_body) : ScopeName.t * 'e scope_body) =
let get_name t =
match Marked.unmark t with
| TStruct sname -> Format.asprintf "%a" format_struct_name sname
@ -198,13 +199,13 @@ module To_json = struct
format_enum_name ename fmt_enum_properties ename
| _ -> ()))
(collect_required_type_defs_from_scope_input
scope_def.scope_body.scope_body_input_struct)
scope_body.scope_body_input_struct)
let format_program
(fmt : Format.formatter)
(scope : string)
(prgm : 'm Lcalc.Ast.program) =
match find_scope_def scope prgm.scopes with
match find_scope_def scope prgm.code_items with
| None -> Cli.error_print "Internal error: scope '%s' not found." scope
| Some scope_def ->
Cli.call_unstyled (fun _ ->
@ -220,7 +221,7 @@ module To_json = struct
(fmt_definitions prgm.decl_ctx)
scope_def
(fmt_struct_properties prgm.decl_ctx)
scope_def.scope_body.scope_body_input_struct)
(snd scope_def).scope_body_input_struct)
end
let apply

33
compiler/scalc/ast.ml
View File

@ -18,18 +18,18 @@ open Catala_utils
open Shared_ast
module D = Dcalc.Ast
module L = Lcalc.Ast
module TopLevelName = Uid.Make (Uid.MarkedString) ()
module LocalName = Uid.Make (Uid.MarkedString) ()
module FuncName = Uid.Gen ()
module VarName = Uid.Gen ()
let dead_value = LocalName.fresh ("dead_value", Pos.no_pos)
let handle_default = TopLevelName.fresh ("handle_default", Pos.no_pos)
let handle_default_opt = TopLevelName.fresh ("handle_default_opt", Pos.no_pos)
let dead_value = VarName.fresh ("dead_value", Pos.no_pos)
let handle_default = FuncName.fresh ("handle_default", Pos.no_pos)
let handle_default_opt = FuncName.fresh ("handle_default_opt", Pos.no_pos)
type expr = naked_expr Marked.pos
and naked_expr =
| EVar : LocalName.t -> naked_expr
| EFunc : TopLevelName.t -> naked_expr
| EVar : VarName.t -> naked_expr
| EFunc : FuncName.t -> naked_expr
| EStruct : expr list * StructName.t -> naked_expr
| EStructFieldAccess : expr * StructField.t * StructName.t -> naked_expr
| EInj : expr * EnumConstructor.t * EnumName.t -> naked_expr
@ -39,9 +39,9 @@ and naked_expr =
| EOp : (lcalc, _) operator -> naked_expr
type stmt =
| SInnerFuncDef of LocalName.t Marked.pos * func
| SLocalDecl of LocalName.t Marked.pos * typ
| SLocalDef of LocalName.t Marked.pos * expr
| SInnerFuncDef of VarName.t Marked.pos * func
| SLocalDecl of VarName.t Marked.pos * typ
| SLocalDef of VarName.t Marked.pos * expr
| STryExcept of block * except * block
| SRaise of except
| SIfThenElse of expr * block * block
@ -49,7 +49,7 @@ type stmt =
expr
* EnumName.t
* (block (* Statements corresponding to arm closure body*)
* (* Variable instantiated with enum payload *) LocalName.t)
* (* Variable instantiated with enum payload *) VarName.t)
list (** Each block corresponds to one case of the enum *)
| SReturn of naked_expr
| SAssert of naked_expr
@ -57,14 +57,19 @@ type stmt =
and block = stmt Marked.pos list
and func = {
func_params : (LocalName.t Marked.pos * typ) list;
func_params : (VarName.t Marked.pos * typ) list;
func_body : block;
}
type scope_body = {
scope_body_name : ScopeName.t;
scope_body_var : TopLevelName.t;
scope_body_var : FuncName.t;
scope_body_func : func;
}
type program = { decl_ctx : decl_ctx; scopes : scope_body list }
type code_item =
| SVar of { var : VarName.t; expr : expr }
| SFunc of { var : FuncName.t; func : func }
| SScope of scope_body
type program = { decl_ctx : decl_ctx; code_items : code_item list }

210
compiler/scalc/compile_from_lambda.ml → compiler/scalc/from_lcalc.ml
View File

@ -21,10 +21,10 @@ module L = Lcalc.Ast
module D = Dcalc.Ast
type 'm ctxt = {
func_dict : ('m L.expr, A.TopLevelName.t) Var.Map.t;
func_dict : ('m L.expr, A.FuncName.t) Var.Map.t;
decl_ctx : decl_ctx;
var_dict : ('m L.expr, A.LocalName.t) Var.Map.t;
inside_definition_of : A.LocalName.t option;
var_dict : ('m L.expr, A.VarName.t) Var.Map.t;
inside_definition_of : A.VarName.t option;
context_name : string;
}
@ -90,14 +90,14 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
| ELit l -> [], (A.ELit l, Expr.pos expr)
| _ ->
let tmp_var =
A.LocalName.fresh
A.VarName.fresh
( (*This piece of logic is used to make the code more readable. TODO:
should be removed when
https://github.com/CatalaLang/catala/issues/240 is fixed. *)
(match ctxt.inside_definition_of with
| None -> ctxt.context_name
| Some v ->
let v = Marked.unmark (A.LocalName.get_info v) in
let v = Marked.unmark (A.VarName.get_info v) in
let tmp_rex = Re.Pcre.regexp "^temp_" in
if Re.Pcre.pmatch ~rex:tmp_rex v then v else "temp_" ^ v),
Expr.pos expr )
@ -106,7 +106,7 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
{
ctxt with
inside_definition_of = Some tmp_var;
context_name = Marked.unmark (A.LocalName.get_info tmp_var);
context_name = Marked.unmark (A.VarName.get_info tmp_var);
}
in
let tmp_stmts = translate_statements ctxt expr in
@ -133,7 +133,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
List.fold_left
(fun var_dict (x, _) ->
Var.Map.add x
(A.LocalName.fresh (Bindlib.name_of x, binder_pos))
(A.VarName.fresh (Bindlib.name_of x, binder_pos))
var_dict)
ctxt.var_dict vars_tau;
}
@ -159,7 +159,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
ctxt with
inside_definition_of = Some (Marked.unmark x);
context_name =
Marked.unmark (A.LocalName.get_info (Marked.unmark x));
Marked.unmark (A.VarName.get_info (Marked.unmark x));
}
in
let arg_stmts, new_arg = translate_expr ctxt arg in
@ -174,7 +174,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
let vars_tau = List.map2 (fun x tau -> x, tau) (Array.to_list vars) tys in
let closure_name =
match ctxt.inside_definition_of with
| None -> A.LocalName.fresh (ctxt.context_name, Expr.pos block_expr)
| None -> A.VarName.fresh (ctxt.context_name, Expr.pos block_expr)
| Some x -> x
in
let ctxt =
@ -184,7 +184,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
List.fold_left
(fun var_dict (x, _) ->
Var.Map.add x
(A.LocalName.fresh (Bindlib.name_of x, binder_pos))
(A.VarName.fresh (Bindlib.name_of x, binder_pos))
var_dict)
ctxt.var_dict vars_tau;
inside_definition_of = None;
@ -215,7 +215,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
assert (Array.length vars = 1);
let var = vars.(0) in
let scalc_var =
A.LocalName.fresh (Bindlib.name_of var, Expr.pos arg)
A.VarName.fresh (Bindlib.name_of var, Expr.pos arg)
in
let ctxt =
{ ctxt with var_dict = Var.Map.add var scalc_var ctxt.var_dict }
@ -272,8 +272,8 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
let rec translate_scope_body_expr
(scope_name : ScopeName.t)
(decl_ctx : decl_ctx)
(var_dict : ('m L.expr, A.LocalName.t) Var.Map.t)
(func_dict : ('m L.expr, A.TopLevelName.t) Var.Map.t)
(var_dict : ('m L.expr, A.VarName.t) Var.Map.t)
(func_dict : ('m L.expr, A.FuncName.t) Var.Map.t)
(scope_expr : 'm L.expr scope_body_expr) : A.block =
match scope_expr with
| Result e ->
@ -292,7 +292,7 @@ let rec translate_scope_body_expr
| ScopeLet scope_let ->
let let_var, scope_let_next = Bindlib.unbind scope_let.scope_let_next in
let let_var_id =
A.LocalName.fresh (Bindlib.name_of let_var, scope_let.scope_let_pos)
A.VarName.fresh (Bindlib.name_of let_var, scope_let.scope_let_pos)
in
let new_var_dict = Var.Map.add let_var let_var_id var_dict in
(match scope_let.scope_let_kind with
@ -330,54 +330,136 @@ let rec translate_scope_body_expr
scope_let_next
let translate_program (p : 'm L.program) : A.program =
{
decl_ctx = p.decl_ctx;
scopes =
(let _, new_scopes =
Scope.fold_left
~f:(fun (func_dict, new_scopes) scope_def scope_var ->
let scope_input_var, scope_body_expr =
Bindlib.unbind scope_def.scope_body.scope_body_expr
in
let input_pos =
Marked.get_mark (ScopeName.get_info scope_def.scope_name)
in
let scope_input_var_id =
A.LocalName.fresh (Bindlib.name_of scope_input_var, input_pos)
in
let var_dict =
Var.Map.singleton scope_input_var scope_input_var_id
in
let new_scope_body =
translate_scope_body_expr scope_def.scope_name p.decl_ctx
var_dict func_dict scope_body_expr
in
let func_id =
A.TopLevelName.fresh (Bindlib.name_of scope_var, Pos.no_pos)
in
let func_dict = Var.Map.add scope_var func_id func_dict in
( func_dict,
{
Ast.scope_body_name = scope_def.scope_name;
Ast.scope_body_var = func_id;
scope_body_func =
let _, _, rev_items =
Scope.fold_left
~f:(fun (func_dict, var_dict, rev_items) code_item var ->
match code_item with
| ScopeDef (name, body) ->
let scope_input_var, scope_body_expr =
Bindlib.unbind body.scope_body_expr
in
let input_pos = Marked.get_mark (ScopeName.get_info name) in
let scope_input_var_id =
A.VarName.fresh (Bindlib.name_of scope_input_var, input_pos)
in
let var_dict_local =
Var.Map.add scope_input_var scope_input_var_id var_dict
in
let new_scope_body =
translate_scope_body_expr name p.decl_ctx var_dict_local func_dict
scope_body_expr
in
let func_id = A.FuncName.fresh (Bindlib.name_of var, Pos.no_pos) in
( Var.Map.add var func_id func_dict,
var_dict,
A.SScope
{
Ast.scope_body_name = name;
Ast.scope_body_var = func_id;
scope_body_func =
{
A.func_params =
[
( (scope_input_var_id, input_pos),
(TStruct body.scope_body_input_struct, input_pos) );
];
A.func_body = new_scope_body;
};
}
:: rev_items )
| Topdef (name, _, (EAbs abs, _)) ->
(* Toplevel function def *)
let func_id = A.FuncName.fresh (Bindlib.name_of var, Pos.no_pos) in
let args_a, expr = Bindlib.unmbind abs.binder in
let args = Array.to_list args_a in
let args_id =
List.map2
(fun v ty ->
let pos = Marked.get_mark ty in
(A.VarName.fresh (Bindlib.name_of v, pos), pos), ty)
args abs.tys
in
let block, expr =
let ctxt =
{
func_dict;
decl_ctx = p.decl_ctx;
var_dict =
List.fold_left2
(fun map arg ((id, _), _) -> Var.Map.add arg id map)
var_dict args args_id;
inside_definition_of = None;
context_name = Marked.unmark (TopdefName.get_info name);
}
in
translate_expr ctxt expr
in
let body_block =
block @ [A.SReturn (Marked.unmark expr), Marked.get_mark expr]
in
( Var.Map.add var func_id func_dict,
var_dict,
A.SFunc
{
var = func_id;
func = { A.func_params = args_id; A.func_body = body_block };
}
:: rev_items )
| Topdef (name, _ty, expr) ->
(* Toplevel constant def *)
let var_id = A.VarName.fresh (Bindlib.name_of var, Pos.no_pos) in
let block, expr =
let ctxt =
{
func_dict;
decl_ctx = p.decl_ctx;
var_dict;
inside_definition_of = None;
context_name = Marked.unmark (TopdefName.get_info name);
}
in
translate_expr ctxt expr
in
(* If the evaluation of the toplevel expr requires preliminary
statements, we lift its computation into an auxiliary function *)
let rev_items =
match block with
| [] -> A.SVar { var = var_id; expr } :: rev_items
| block ->
let pos = Marked.get_mark expr in
let func_id =
A.FuncName.fresh (Bindlib.name_of var ^ "_aux", pos)
in
(* The list is being built in reverse order *)
A.SVar
{ var = var_id; expr = A.EApp ((EFunc func_id, pos), []), pos }
:: A.SFunc
{
A.func_params =
[
( (scope_input_var_id, input_pos),
( TStruct scope_def.scope_body.scope_body_input_struct,
input_pos ) );
];
A.func_body = new_scope_body;
};
}
:: new_scopes ))
~init:
( (if !Cli.avoid_exceptions_flag then
Var.Map.singleton L.handle_default_opt A.handle_default_opt
else Var.Map.singleton L.handle_default A.handle_default),
[] )
p.scopes
in
List.rev new_scopes);
}
var = func_id;
func =
{
A.func_params = [];
A.func_body =
block
@ [
( A.SReturn (Marked.unmark expr),
Marked.get_mark expr );
];
};
}
:: rev_items
in
( func_dict,
(* No need to add func_id since the function will only be called
right here *)
Var.Map.add var var_id var_dict,
rev_items ))
~init:
( (if !Cli.avoid_exceptions_flag then
Var.Map.singleton L.handle_default_opt A.handle_default_opt
else Var.Map.singleton L.handle_default A.handle_default),
Var.Map.empty,
[] )
p.code_items
in
{ decl_ctx = p.decl_ctx; code_items = List.rev rev_items }

19
compiler/scalc/from_lcalc.mli Normal file
View File

@ -0,0 +1,19 @@
(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2021 Inria, contributor:
Louis Gesbert <louis.gesbert@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
open Shared_ast
val translate_program : untyped Lcalc.Ast.program -> Ast.program

75
compiler/scalc/print.ml
View File

@ -20,9 +20,12 @@ open Ast
let needs_parens (_e : expr) : bool = false
let format_local_name (fmt : Format.formatter) (v : LocalName.t) : unit =
Format.fprintf fmt "%a_%s" LocalName.format_t v
(string_of_int (LocalName.hash v))
let format_var_name (fmt : Format.formatter) (v : VarName.t) : unit =
Format.fprintf fmt "%a_%s" VarName.format_t v (string_of_int (VarName.hash v))
let format_func_name (fmt : Format.formatter) (v : FuncName.t) : unit =
Format.fprintf fmt "%a_%s" FuncName.format_t v
(string_of_int (FuncName.hash v))
let rec format_expr
(decl_ctx : decl_ctx)
@ -37,8 +40,8 @@ let rec format_expr
else Format.fprintf fmt "%a" format_expr e
in
match Marked.unmark e with
| EVar v -> Format.fprintf fmt "%a" format_local_name v
| EFunc v -> Format.fprintf fmt "%a" TopLevelName.format_t v
| EVar v -> Format.fprintf fmt "%a" format_var_name v
| EFunc v -> Format.fprintf fmt "%a" format_func_name v
| EStruct (es, s) ->
Format.fprintf fmt "@[<hov 2>%a@ %a%a%a@]" StructName.format_t s
Print.punctuation "{"
@ -75,6 +78,7 @@ let rec format_expr
| EApp ((EOp op, _), [arg1]) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" Print.operator op format_with_parens
arg1
| EApp (f, []) -> Format.fprintf fmt "@[<hov 2>%a@ ()@]" format_expr f
| EApp (f, args) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" format_expr f
(Format.pp_print_list
@ -92,22 +96,22 @@ let rec format_statement
match Marked.unmark stmt with
| SInnerFuncDef (name, func) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@]@\n@[<v 2> %a@]" Print.keyword
"let" format_local_name (Marked.unmark name)
"let" format_var_name (Marked.unmark name)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt ((name, _), typ) ->
Format.fprintf fmt "%a%a %a@ %a%a" Print.punctuation "("
format_local_name name Print.punctuation ":" (Print.typ decl_ctx)
typ Print.punctuation ")"))
format_var_name name Print.punctuation ":" (Print.typ decl_ctx) typ
Print.punctuation ")"))
func.func_params Print.punctuation "="
(format_block decl_ctx ~debug)
func.func_body
| SLocalDecl (name, typ) ->
Format.fprintf fmt "@[<hov 2>%a %a %a@ %a@]" Print.keyword "decl"
format_local_name (Marked.unmark name) Print.punctuation ":"
format_var_name (Marked.unmark name) Print.punctuation ":"
(Print.typ decl_ctx) typ
| SLocalDef (name, naked_expr) ->
Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" format_local_name
Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" format_var_name
(Marked.unmark name) Print.punctuation "="
(format_expr decl_ctx ~debug)
naked_expr
@ -147,7 +151,7 @@ let rec format_statement
(fun fmt ((case, _), (arm_block, payload_name)) ->
Format.fprintf fmt "%a %a%a@ %a @[<v 2>%a@ %a@]" Print.punctuation
"|" Print.enum_constructor case Print.punctuation ":"
format_local_name payload_name Print.punctuation "→"
format_var_name payload_name Print.punctuation "→"
(format_block decl_ctx ~debug)
arm_block))
(List.combine
@ -165,20 +169,35 @@ and format_block
(format_statement decl_ctx ~debug)
fmt block
let format_scope
(decl_ctx : decl_ctx)
?(debug : bool = false)
(fmt : Format.formatter)
(body : scope_body) : unit =
if debug then () else ();
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@]@\n@[<v 2> %a@]" Print.keyword
"let" TopLevelName.format_t body.scope_body_var
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt ((name, _), typ) ->
Format.fprintf fmt "%a%a %a@ %a%a" Print.punctuation "("
format_local_name name Print.punctuation ":" (Print.typ decl_ctx) typ
Print.punctuation ")"))
body.scope_body_func.func_params Print.punctuation "="
(format_block decl_ctx ~debug)
body.scope_body_func.func_body
let format_item decl_ctx ?debug ppf def =
Format.pp_open_hvbox ppf 2;
Format.pp_open_hovbox ppf 4;
Print.keyword ppf "let ";
let () =
match def with
| SVar { var; expr } ->
format_var_name ppf var;
Print.punctuation ppf " =";
Format.pp_close_box ppf ();
Format.pp_print_space ppf ();
format_expr decl_ctx ?debug ppf expr
| SScope { scope_body_var = var; scope_body_func = func; _ }
| SFunc { var; func } ->
format_func_name ppf var;
Format.pp_print_list
(fun ppf (arg, ty) ->
Format.fprintf ppf "@ (%a: %a)" format_var_name (Marked.unmark arg)
(Print.typ decl_ctx) ty)
ppf func.func_params;
Print.punctuation ppf " =";
Format.pp_close_box ppf ();
Format.pp_print_space ppf ();
format_block decl_ctx ?debug ppf func.func_body
in
Format.pp_close_box ppf ();
Format.pp_print_cut ppf ()
let format_program decl_ctx ?debug ppf prg =
Format.pp_open_vbox ppf 0;
Format.pp_print_list (format_item decl_ctx ?debug) ppf prg.code_items;
Format.pp_close_box ppf ()

7
compiler/scalc/print.mli
View File

@ -14,9 +14,12 @@
License for the specific language governing permissions and limitations under
the License. *)
val format_scope :
val format_item :
Shared_ast.decl_ctx ->
?debug:bool ->
Format.formatter ->
Ast.scope_body ->
Ast.code_item ->
unit
val format_program :
Shared_ast.decl_ctx -> ?debug:bool -> Format.formatter -> Ast.program -> unit

4
compiler/scalc/scalc.mld
View File

@ -12,13 +12,13 @@ The module describing the abstract syntax tree is:
{1 Compilation from lambda calculus }
{!module: Scalc.Compile_from_lambda} Performs the classical translation
{!module: Scalc.From_lambda} Performs the classical translation
from an expression-based language to a statement-based language. Union types
are eliminated in favor of tagged unions.
Related modules:
{!modules: Scalc.Compile_from_lambda}
{!modules: Scalc.From_lambda}
{1 Backends}

61
compiler/scalc/to_python.ml
View File

@ -78,8 +78,8 @@ let format_op
Format.pp_print_string fmt "-"
| Mult_int_int | Mult_rat_rat | Mult_mon_rat | Mult_dur_int ->
Format.pp_print_string fmt "*"
| Div_int_int -> Format.pp_print_string fmt "//"
| Div_rat_rat | Div_mon_mon | Div_mon_rat -> Format.pp_print_string fmt "/"
| Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat ->
Format.pp_print_string fmt "/"
| And -> Format.pp_print_string fmt "and"
| Or -> Format.pp_print_string fmt "or"
| Eq -> Format.pp_print_string fmt "=="
@ -186,8 +186,11 @@ let rec format_typ (fmt : Format.formatter) (typ : typ) : unit =
Format.fprintf fmt "Optional[%a]" format_typ some_typ
| TEnum e -> Format.fprintf fmt "%a" format_enum_name e
| TArrow (t1, t2) ->
Format.fprintf fmt "Callable[[%a], %a]" format_typ_with_parens t1
format_typ_with_parens t2
Format.fprintf fmt "Callable[[%a], %a]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
format_typ_with_parens)
t1 format_typ_with_parens t2
| TArray t1 -> Format.fprintf fmt "List[%a]" format_typ_with_parens t1
| TAny -> Format.fprintf fmt "Any"
@ -203,16 +206,16 @@ let format_name_cleaned (fmt : Format.formatter) (s : string) : unit =
module StringMap = Map.Make (String)
module IntMap = Map.Make (Int)
(** For each `LocalName.t` defined by its string and then by its hash, we keep
(** For each `VarName.t` defined by its string and then by its hash, we keep
track of which local integer id we've given it. This is used to keep
variable naming with low indices rather than one global counter for all
variables. TODO: should be removed when
https://github.com/CatalaLang/catala/issues/240 is fixed. *)
let string_counter_map : int IntMap.t StringMap.t ref = ref StringMap.empty
let format_var (fmt : Format.formatter) (v : LocalName.t) : unit =
let v_str = Marked.unmark (LocalName.get_info v) in
let hash = LocalName.hash v in
let format_var (fmt : Format.formatter) (v : VarName.t) : unit =
let v_str = Marked.unmark (VarName.get_info v) in
let hash = VarName.hash v in
let local_id =
match StringMap.find_opt v_str !string_counter_map with
| Some ids -> (
@ -241,10 +244,13 @@ let format_var (fmt : Format.formatter) (v : LocalName.t) : unit =
else if local_id = 0 then format_name_cleaned fmt v_str
else Format.fprintf fmt "%a_%d" format_name_cleaned v_str local_id
let format_toplevel_name (fmt : Format.formatter) (v : TopLevelName.t) : unit =
let v_str = Marked.unmark (TopLevelName.get_info v) in
let format_func_name (fmt : Format.formatter) (v : FuncName.t) : unit =
let v_str = Marked.unmark (FuncName.get_info v) in
format_name_cleaned fmt v_str
let format_var_name (fmt : Format.formatter) (v : VarName.t) : unit =
Format.fprintf fmt "%a_%s" VarName.format_t v (string_of_int (VarName.hash v))
let needs_parens (e : expr) : bool =
match Marked.unmark e with
| ELit (LBool _ | LUnit) | EVar _ | EOp _ -> false
@ -276,7 +282,7 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
unit =
match Marked.unmark e with
| EVar v -> format_var fmt v
| EFunc f -> format_toplevel_name fmt f
| EFunc f -> format_func_name fmt f
| EStruct (es, s) ->
Format.fprintf fmt "%a(%a)" format_struct_name s
(Format.pp_print_list
@ -348,12 +354,12 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
Format.fprintf fmt "%a(%a)" format_op (op, Pos.no_pos)
(format_expression ctx) arg1
| EApp ((EFunc x, pos), args)
when Ast.TopLevelName.compare x Ast.handle_default = 0
|| Ast.TopLevelName.compare x Ast.handle_default_opt = 0 ->
when Ast.FuncName.compare x Ast.handle_default = 0
|| Ast.FuncName.compare x Ast.handle_default_opt = 0 ->
Format.fprintf fmt
"%a(@[<hov 0>SourcePosition(filename=\"%s\",@ start_line=%d,@ \
start_column=%d,@ end_line=%d, end_column=%d,@ law_headings=%a), %a)@]"
format_toplevel_name x (Pos.get_file pos) (Pos.get_start_line pos)
format_func_name x (Pos.get_file pos) (Pos.get_start_line pos)
(Pos.get_start_column pos) (Pos.get_end_line pos) (Pos.get_end_column pos)
format_string_list (Pos.get_law_info pos)
(Format.pp_print_list
@ -400,7 +406,7 @@ let rec format_statement
| SSwitch (e1, e_name, [(case_none, _); (case_some, case_some_var)])
when EnumName.compare e_name L.option_enum = 0 ->
(* We translate the option type with an overloading by Python's [None] *)
let tmp_var = LocalName.fresh ("perhaps_none_arg", Pos.no_pos) in
let tmp_var = VarName.fresh ("perhaps_none_arg", Pos.no_pos) in
Format.fprintf fmt
"%a = %a@\n\
@[<hov 4>if %a is None:@\n\
@ -418,7 +424,7 @@ let rec format_statement
cases
(EnumConstructor.Map.bindings (EnumName.Map.find e_name ctx.ctx_enums))
in
let tmp_var = LocalName.fresh ("match_arg", Pos.no_pos) in
let tmp_var = VarName.fresh ("match_arg", Pos.no_pos) in
Format.fprintf fmt "%a = %a@\n@[<hov 4>if %a@]" format_var tmp_var
(format_expression ctx) e1
(Format.pp_print_list
@ -583,7 +589,7 @@ let format_program
(* We disable the style flag in order to enjoy formatting from the
pretty-printers of Dcalc and Lcalc but without the color terminal
markers. *)
Cli.call_unstyled (fun _ ->
Cli.call_unstyled (fun () ->
Format.fprintf fmt
"# This file has been generated by the Catala compiler, do not edit!\n\
@\n\
@ -591,20 +597,25 @@ let format_program
from typing import Any, List, Callable, Tuple\n\
from enum import Enum\n\
@\n\
%a@\n\
@[<v>%a@]@\n\
@\n\
%a@?"
(format_ctx type_ordering) p.decl_ctx
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n@\n")
(fun fmt body ->
let { Ast.func_params; Ast.func_body } = body.scope_body_func in
Format.fprintf fmt "@[<hov 4>def %a(%a):@\n%a@]"
format_toplevel_name body.scope_body_var
(Format.pp_print_list ~pp_sep:Format.pp_print_newline (fun fmt ->
function
| SVar { var; expr } ->
Format.fprintf fmt "@[<hv 4>%a = (@,%a@,@])@," format_var var
(format_expression p.decl_ctx)
expr
| SFunc { var; func }
| SScope { scope_body_var = var; scope_body_func = func; _ } ->
let { Ast.func_params; Ast.func_body } = func in
Format.fprintf fmt "@[<hv 4>def %a(%a):@\n%a@]@," format_func_name
var
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
(fun fmt (var, typ) ->
Format.fprintf fmt "%a:%a" format_var (Marked.unmark var)
format_typ typ))
func_params (format_block p.decl_ctx) func_body))
p.scopes)
p.code_items)

16
compiler/scopelang/ast.ml
View File

@ -53,6 +53,7 @@ type 'm scope_decl = {
type 'm program = {
program_scopes : 'm scope_decl ScopeName.Map.t;
program_topdefs : ('m expr * typ) TopdefName.Map.t;
program_ctx : decl_ctx;
}
@ -69,12 +70,23 @@ let type_rule decl_ctx env = function
Call (sc_name, ssc_name, Typed { pos; ty = Marked.mark pos TAny })
let type_program (prg : 'm program) : typed program =
let typing_env =
TopdefName.Map.fold
(fun name (_, ty) -> Typing.Env.add_toplevel_var name ty)
prg.program_topdefs Typing.Env.empty
in
let program_topdefs =
TopdefName.Map.map
(fun (expr, typ) ->
Expr.unbox (Typing.expr prg.program_ctx ~env:typing_env ~typ expr), typ)
prg.program_topdefs
in
let typing_env =
ScopeName.Map.fold
(fun scope_name scope_decl ->
let vars = ScopeVar.Map.map fst scope_decl.scope_sig in
Typing.Env.add_scope scope_name ~vars)
prg.program_scopes Typing.Env.empty
prg.program_scopes typing_env
in
let program_scopes =
ScopeName.Map.map
@ -98,4 +110,4 @@ let type_program (prg : 'm program) : typed program =
{ scope_decl with scope_decl_rules; scope_mark })
prg.program_scopes
in
{ prg with program_scopes }
{ prg with program_topdefs; program_scopes }

1
compiler/scopelang/ast.mli
View File

@ -45,6 +45,7 @@ type 'm scope_decl = {
type 'm program = {
program_scopes : 'm scope_decl ScopeName.Map.t;
program_topdefs : ('m expr * typ) TopdefName.Map.t;
program_ctx : decl_ctx;
}

110
compiler/scopelang/dependency.ml
View File

@ -19,7 +19,46 @@
open Catala_utils
open Shared_ast
module SVertex = ScopeName
type vertex = Scope of ScopeName.t | Topdef of TopdefName.t
module SVertex = struct
type t = vertex
(* While we enforce that globals don't depend on scopes, and could therefore
compute two separate dependency graphs and traverse them one after the
other, code-wise it's simpler to have a single graph including both *)
let compare v1 v2 =
match v1, v2 with
| Scope s1, Scope s2 -> ScopeName.compare s1 s2
| Topdef g1, Topdef g2 -> TopdefName.compare g1 g2
| Scope _, _ -> -1
| _, Scope _ -> 1
| Topdef _, _ | _, Topdef _ -> .
let equal v1 v2 =
match v1, v2 with
| Scope s1, Scope s2 -> ScopeName.equal s1 s2
| Topdef g1, Topdef g2 -> TopdefName.equal g1 g2
| (Scope _ | Topdef _), _ -> false
let hash = function
| Scope s -> ScopeName.hash s
| Topdef g -> TopdefName.hash g
let to_string v =
Format.asprintf "%a"
(fun ppf -> function
| Scope s -> ScopeName.format_t ppf s
| Topdef g -> TopdefName.format_t ppf g)
v
let info = function
| Scope s -> ScopeName.get_info s
| Topdef g -> TopdefName.get_info g
end
module VMap = Map.Make (SVertex)
(** On the edges, the label is the expression responsible for the use of the
function *)
@ -38,56 +77,81 @@ module STopologicalTraversal = Graph.Topological.Make (SDependencies)
module SSCC = Graph.Components.Make (SDependencies)
(** Tarjan's stongly connected components algorithm, provided by OCamlGraph *)
let rec expr_used_scopes e =
let rec expr_used_defs e =
let recurse_subterms e =
Expr.shallow_fold
(fun e -> ScopeName.Map.union (fun _ x _ -> Some x) (expr_used_scopes e))
e ScopeName.Map.empty
(fun e -> VMap.union (fun _ x _ -> Some x) (expr_used_defs e))
e VMap.empty
in
match e with
| ELocation (ToplevelVar (v, pos)), _ -> VMap.singleton (Topdef v) pos
| (EScopeCall { scope; _ }, m) as e ->
ScopeName.Map.add scope (Expr.mark_pos m) (recurse_subterms e)
VMap.add (Scope scope) (Expr.mark_pos m) (recurse_subterms e)
| EAbs { binder; _ }, _ ->
let _, body = Bindlib.unmbind binder in
expr_used_scopes body
expr_used_defs body
| e -> recurse_subterms e
let rule_used_scopes = function
let rule_used_defs = function
| Ast.Assertion e | Ast.Definition (_, _, _, e) ->
(* TODO: maybe this info could be passed on from previous passes without
walking through all exprs again *)
expr_used_scopes e
expr_used_defs e
| Ast.Call (subscope, subindex, _) ->
ScopeName.Map.singleton subscope
VMap.singleton (Scope subscope)
(Marked.get_mark (SubScopeName.get_info subindex))
let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t =
let g = SDependencies.empty in
let g =
TopdefName.Map.fold
(fun v _ g -> SDependencies.add_vertex g (Topdef v))
prgm.program_topdefs g
in
let g =
ScopeName.Map.fold
(fun v _ g -> SDependencies.add_vertex g v)
(fun v _ g -> SDependencies.add_vertex g (Scope v))
prgm.program_scopes g
in
let g =
TopdefName.Map.fold
(fun glo_name (expr, _) g ->
let used_defs = expr_used_defs expr in
if VMap.mem (Topdef glo_name) used_defs then
Errors.raise_spanned_error
(Marked.get_mark (TopdefName.get_info glo_name))
"The Topdef %a has a definition that refers to itself, which is \
forbidden since Catala does not provide recursion"
TopdefName.format_t glo_name;
VMap.fold
(fun def pos g ->
let edge = SDependencies.E.create def pos (Topdef glo_name) in
SDependencies.add_edge_e g edge)
used_defs g)
prgm.program_topdefs g
in
ScopeName.Map.fold
(fun scope_name scope g ->
List.fold_left
(fun g rule ->
let used_scopes = rule_used_scopes rule in
if ScopeName.Map.mem scope_name used_scopes then
let used_defs = rule_used_defs rule in
if VMap.mem (Scope scope_name) used_defs then
Errors.raise_spanned_error
(Marked.get_mark (ScopeName.get_info scope.Ast.scope_decl_name))
"The scope %a is calling into itself as a subscope, which is \
forbidden since Catala does not provide recursion"
ScopeName.format_t scope.Ast.scope_decl_name;
ScopeName.Map.fold
(fun used_scope pos g ->
let edge = SDependencies.E.create used_scope pos scope_name in
VMap.fold
(fun used_def pos g ->
let edge =
SDependencies.E.create used_def pos (Scope scope_name)
in
SDependencies.add_edge_e g edge)
used_scopes g)
used_defs g)
g scope.Ast.scope_decl_rules)
prgm.program_scopes g
let check_for_cycle_in_scope (g : SDependencies.t) : unit =
let check_for_cycle_in_defs (g : SDependencies.t) : unit =
(* if there is a cycle, there will be an strongly connected component of
cardinality > 1 *)
let sccs = SSCC.scc_list g in
@ -97,14 +161,12 @@ let check_for_cycle_in_scope (g : SDependencies.t) : unit =
List.flatten
(List.map
(fun v ->
let var_str, var_info =
Format.asprintf "%a" ScopeName.format_t v, ScopeName.get_info v
in
let var_str, var_info = SVertex.to_string v, SVertex.info v in
let succs = SDependencies.succ_e g v in
let _, edge_pos, succ =
List.find (fun (_, _, succ) -> List.mem succ scc) succs
in
let succ_str = Format.asprintf "%a" ScopeName.format_t succ in
let succ_str = SVertex.to_string succ in
[
( Some ("Cycle variable " ^ var_str ^ ", declared:"),
Marked.get_mark var_info );
@ -119,7 +181,7 @@ let check_for_cycle_in_scope (g : SDependencies.t) : unit =
Errors.raise_multispanned_error spans
"Cyclic dependency detected between scopes!"
let get_scope_ordering (g : SDependencies.t) : ScopeName.t list =
let get_defs_ordering (g : SDependencies.t) : SVertex.t list =
List.rev (STopologicalTraversal.fold (fun sd acc -> sd :: acc) g [])
module TVertex = struct
@ -177,7 +239,9 @@ let rec get_structs_or_enums_in_type (t : typ) : TVertexSet.t =
| TEnum e -> TVertexSet.singleton (TVertex.Enum e)
| TArrow (t1, t2) ->
TVertexSet.union
(get_structs_or_enums_in_type t1)
(t1
|> List.map get_structs_or_enums_in_type
|> List.fold_left TVertexSet.union TVertexSet.empty)
(get_structs_or_enums_in_type t2)
| TLit _ | TAny -> TVertexSet.empty
| TOption t1 | TArray t1 -> get_structs_or_enums_in_type t1

8
compiler/scopelang/dependency.mli
View File

@ -22,14 +22,16 @@ open Shared_ast
(** {1 Scope dependencies} *)
type vertex = Scope of ScopeName.t | Topdef of TopdefName.t
(** On the edges, the label is the expression responsible for the use of the
function *)
module SDependencies :
Graph.Sig.P with type V.t = ScopeName.t and type E.label = Pos.t
Graph.Sig.P with type V.t = vertex and type E.label = Pos.t
val build_program_dep_graph : 'm Ast.program -> SDependencies.t
val check_for_cycle_in_scope : SDependencies.t -> unit
val get_scope_ordering : SDependencies.t -> ScopeName.t list
val check_for_cycle_in_defs : SDependencies.t -> unit
val get_defs_ordering : SDependencies.t -> vertex list
(** {1 Type dependencies} *)

83
compiler/scopelang/from_desugared.ml
View File

@ -71,6 +71,7 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) :
| WholeVar _ -> failwith "should not happen"
| States states -> Marked.same_mark_as (List.assoc state states) s_var))
m
| ELocation (ToplevelVar v) -> Expr.elocation (ToplevelVar v) m
| EVar v -> Expr.evar (Var.Map.find v ctx.var_mapping) m
| EStruct { name; fields } ->
Expr.estruct name (StructField.Map.map (translate_expr ctx) fields) m
@ -93,6 +94,9 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) :
name
in
Expr.estructaccess e' field name m
| ETuple es -> Expr.etuple (List.map (translate_expr ctx) es) m
| ETupleAccess { e; index; size } ->
Expr.etupleaccess (translate_expr ctx e) index size m
| EInj { e; cons; name } -> Expr.einj (translate_expr ctx e) cons name m
| EMatch { e; name; cases } ->
Expr.ematch (translate_expr ctx e) name
@ -208,26 +212,29 @@ let rec rule_tree_to_expr
~(is_reentrant_var : bool)
(ctx : ctx)
(def_pos : Pos.t)
(is_func : Desugared.Ast.expr Var.t option)
(is_func : Desugared.Ast.expr Var.t list option)
(tree : rule_tree) : untyped Ast.expr boxed =
let emark = Untyped { pos = def_pos } in
let exceptions, base_rules =
match tree with Leaf r -> [], r | Node (exceptions, r) -> exceptions, r
in
(* because each rule has its own variable parameter and we want to convert the
whole rule tree into a function, we need to perform some alpha-renaming of
all the expressions *)
(* because each rule has its own variables parameters and we want to convert
the whole rule tree into a function, we need to perform some alpha-renaming
of all the expressions *)
let substitute_parameter
(e : Desugared.Ast.expr boxed)
(rule : Desugared.Ast.rule) : Desugared.Ast.expr boxed =
match is_func, rule.Desugared.Ast.rule_parameter with
| Some new_param, Some (old_param, _) ->
let binder = Bindlib.bind_var old_param (Marked.unmark e) in
| Some new_params, Some old_params_with_types ->
let old_params, _ = List.split old_params_with_types in
let old_params = Array.of_list old_params in
let new_params = Array.of_list new_params in
let binder = Bindlib.bind_mvar old_params (Marked.unmark e) in
Marked.mark (Marked.get_mark e)
@@ Bindlib.box_apply2
(fun binder new_param -> Bindlib.subst binder new_param)
(fun binder new_param -> Bindlib.msubst binder new_param)
binder
(Bindlib.box_var new_param)
(new_params |> Array.map Bindlib.box_var |> Bindlib.box_array)
| None, None -> e
| _ -> assert false
(* should not happen *)
@ -235,20 +242,22 @@ let rec rule_tree_to_expr
let ctx =
match is_func with
| None -> ctx
| Some new_param -> (
match Var.Map.find_opt new_param ctx.var_mapping with
| None ->
let new_param_scope = Var.make (Bindlib.name_of new_param) in
{
ctx with
var_mapping = Var.Map.add new_param new_param_scope ctx.var_mapping;
}
| Some _ ->
(* We only create a mapping if none exists because [rule_tree_to_expr]
is called recursively on the exceptions of the tree and we don't want
to create a new Scopelang variable for the parameter at each tree
level. *)
ctx)
| Some new_params ->
ListLabels.fold_left new_params ~init:ctx ~f:(fun ctx new_param ->
match Var.Map.find_opt new_param ctx.var_mapping with
| None ->
let new_param_scope = Var.make (Bindlib.name_of new_param) in
{
ctx with
var_mapping =
Var.Map.add new_param new_param_scope ctx.var_mapping;
}
| Some _ ->
(* We only create a mapping if none exists because
[rule_tree_to_expr] is called recursively on the exceptions of
the tree and we don't want to create a new Scopelang variable for
the parameter at each tree level. *)
ctx)
in
let base_just_list =
List.map
@ -297,7 +306,8 @@ let rec rule_tree_to_expr
in
match is_func, (List.hd base_rules).Desugared.Ast.rule_parameter with
| None, None -> default
| Some new_param, Some (_, typ) ->
| Some new_params, Some ls ->
let _, tys = List.split ls in
if toplevel then
(* When we're creating a function from multiple defaults, we must check
that the result returned by the function is not empty, unless we're
@ -307,9 +317,12 @@ let rec rule_tree_to_expr
let default =
if is_reentrant_var then default else Expr.eerroronempty default emark
in
Expr.make_abs
[| Var.Map.find new_param ctx.var_mapping |]
default [typ] def_pos
(new_params
|> List.map (fun x -> Var.Map.find x ctx.var_mapping)
|> Array.of_list)
default tys def_pos
else default
| _ -> (* should not happen *) assert false
@ -336,7 +349,7 @@ let translate_def
let all_rules_not_func =
RuleName.Map.for_all (fun n r -> not (is_rule_func n r)) def
in
let is_def_func_param_typ : typ option =
let is_def_func_param_typ : typ list option =
if is_def_func && all_rules_func then
match Marked.unmark typ with
| TArrow (t_param, _) -> Some t_param
@ -375,7 +388,7 @@ let translate_def
| Reentrant -> true
| _ -> false
in
let top_value =
let top_value : Desugared.Ast.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,
@ -415,13 +428,19 @@ let translate_def
let m = Untyped { pos = Desugared.Ast.ScopeDef.get_position def_info } in
let empty_error = Expr.elit LEmptyError m in
match is_def_func_param_typ with
| Some ty ->
Expr.make_abs [| Var.make "_" |] empty_error [ty] (Expr.mark_pos m)
| Some tys ->
Expr.make_abs
(Array.init (List.length tys) (fun _ -> Var.make "_"))
empty_error tys (Expr.mark_pos m)
| _ -> empty_error
else
rule_tree_to_expr ~toplevel:true ~is_reentrant_var:is_reentrant ctx
(Desugared.Ast.ScopeDef.get_position def_info)
(Option.map (fun _ -> Var.make "param") is_def_func_param_typ)
(Option.map
(fun l ->
ListLabels.mapi l ~f:(fun i _ ->
Var.make ("param" ^ string_of_int i)))
is_def_func_param_typ)
(match top_list, top_value with
| [], None ->
(* In this case, there are no rules to define the expression and no
@ -724,6 +743,10 @@ let translate_program (pgrm : Desugared.Ast.program) : untyped Ast.program =
pgrm.Desugared.Ast.program_ctx.ctx_scopes
in
{
Ast.program_topdefs =
TopdefName.Map.map
(fun (e, ty) -> Expr.unbox (translate_expr ctx e), ty)
pgrm.program_topdefs;
Ast.program_scopes =
ScopeName.Map.map (translate_scope ctx) pgrm.program_scopes;
program_ctx = { pgrm.program_ctx with ctx_scopes };

25
compiler/scopelang/print.ml
View File

@ -77,7 +77,7 @@ let scope ?(debug = false) ctx fmt (name, decl) =
(Print.typ ctx) typ Print.punctuation "="
(fun fmt e ->
match Marked.unmark loc with
| SubScopeVar _ -> Print.expr ctx fmt e
| SubScopeVar _ | ToplevelVar _ -> Print.expr ctx fmt e
| ScopelangScopeVar v -> (
match
Marked.unmark
@ -98,6 +98,24 @@ let scope ?(debug = false) ctx fmt (name, decl) =
SubScopeName.format_t subscope_name Print.punctuation "]"))
decl.scope_decl_rules
let print_topdef ctx ppf name (e, ty) =
Format.pp_open_vbox ppf 2;
let () =
Format.pp_open_hovbox ppf 2;
Print.keyword ppf "let";
Format.pp_print_space ppf ();
TopdefName.format_t ppf name;
Print.punctuation ppf ":";
Format.pp_print_space ppf ();
Print.typ ctx ppf ty;
Format.pp_print_space ppf ();
Print.punctuation ppf "=";
Format.pp_close_box ppf ()
in
Format.pp_print_cut ppf ();
Print.expr ctx ppf e;
Format.pp_close_box ppf ()
let program ?(debug : bool = false) (fmt : Format.formatter) (p : 'm program) :
unit =
let ctx = p.program_ctx in
@ -116,6 +134,11 @@ let program ?(debug : bool = false) (fmt : Format.formatter) (p : 'm program) :
enum ctx fmt n e;
pp_sep fmt ())
ctx.ctx_enums;
TopdefName.Map.iter
(fun name def ->
print_topdef ctx fmt name def;
pp_sep fmt ())
p.program_topdefs;
Format.pp_print_list ~pp_sep (scope ~debug ctx) fmt
(ScopeName.Map.bindings p.program_scopes);
Format.pp_close_box fmt ()

41
compiler/shared_ast/definitions.ml
View File

@ -23,6 +23,7 @@
open Catala_utils
module Runtime = Runtime_ocaml.Runtime
module ScopeName = Uid.Gen ()
module TopdefName = Uid.Gen ()
module StructName = Uid.Gen ()
module StructField = Uid.Gen ()
module EnumName = Uid.Gen ()
@ -73,7 +74,7 @@ and naked_typ =
| TStruct of StructName.t
| TEnum of EnumName.t
| TOption of typ
| TArrow of typ * typ
| TArrow of typ list * typ
| TArray of typ
| TAny
@ -245,6 +246,9 @@ type 'a glocation =
| SubScopeVar :
ScopeName.t * SubScopeName.t Marked.pos * ScopeVar.t Marked.pos
-> [< desugared | scopelang ] glocation
| ToplevelVar :
TopdefName.t Marked.pos
-> [< desugared | scopelang ] glocation
type ('a, 't) gexpr = (('a, 't) naked_gexpr, 't) Marked.t
(** General expressions: groups all expression cases of the different ASTs, and
@ -301,6 +305,13 @@ and ('a, 't) naked_gexpr =
cases : ('a, 't) gexpr EnumConstructor.Map.t;
}
-> ('a any, 't) naked_gexpr
| ETuple : ('a, 't) gexpr list -> ('a any, 't) naked_gexpr
| ETupleAccess : {
e : ('a, 't) gexpr;
index : int;
size : int;
}
-> ('a any, 't) naked_gexpr
(* Early stages *)
| ELocation :
'a glocation
@ -337,13 +348,6 @@ and ('a, 't) naked_gexpr =
('a, 't) gexpr
-> (([< desugared | scopelang | dcalc ] as 'a), 't) naked_gexpr
(* Lambda calculus with exceptions *)
| ETuple : ('a, 't) gexpr list -> ((lcalc as 'a), 't) naked_gexpr
| ETupleAccess : {
e : ('a, 't) gexpr;
index : int;
size : int;
}
-> ((lcalc as 'a), 't) naked_gexpr
| ERaise : except -> ((lcalc as 'a), 't) naked_gexpr
| ECatch : {
body : ('a, 't) gexpr;
@ -409,6 +413,7 @@ type 'e scope_let = {
scope_let_typ : typ;
scope_let_expr : 'e;
scope_let_next : ('e, 'e scope_body_expr) binder;
(* todo ? Factorise the code_item _list type below and use it here *)
scope_let_pos : Pos.t;
}
constraint 'e = (_ any, _ mark) gexpr
@ -434,19 +439,15 @@ type 'e scope_body = {
a result expression that uses the let-binded variables. The first binder is
the argument of type [scope_body_input_struct]. *)
type 'e scope_def = {
scope_name : ScopeName.t;
scope_body : 'e scope_body;
scope_next : ('e, 'e scopes) binder;
}
constraint 'e = (_ any, _ mark) gexpr
type 'e code_item =
| ScopeDef of ScopeName.t * 'e scope_body
| Topdef of TopdefName.t * typ * 'e
(** Finally, we do the same transformation for the whole program for the kinded
lets. This permit us to use bindlib variables for scopes names. *)
and 'e scopes =
(* A chained list, but with a binder for each element into the next: [x := let a
= e1 in e2] is thus [Cons (e1, {a. Cons (e2, {x. Nil})})] *)
type 'e code_item_list =
| Nil
| ScopeDef of 'e scope_def
constraint 'e = (_ any, _ mark) gexpr
| Cons of 'e code_item * ('e, 'e code_item_list) binder
type struct_ctx = typ StructField.Map.t StructName.Map.t
type enum_ctx = typ EnumConstructor.Map.t EnumName.Map.t
@ -464,4 +465,4 @@ type decl_ctx = {
ctx_scopes : scope_out_struct ScopeName.Map.t;
}
type 'e program = { decl_ctx : decl_ctx; scopes : 'e scopes }
type 'e program = { decl_ctx : decl_ctx; code_items : 'e code_item_list }

38
compiler/shared_ast/expr.ml
View File

@ -182,7 +182,7 @@ let fold_marks
| [] -> invalid_arg "Dcalc.Ast.fold_mark"
| Untyped _ :: _ as ms ->
Untyped { pos = pos_f (List.map (function Untyped { pos } -> pos) ms) }
| Typed _ :: _ ->
| Typed _ :: _ as ms ->
Typed
{
pos = pos_f (List.map (function Typed { pos; _ } -> pos) ms);
@ -469,12 +469,15 @@ let compare_location
SubScopeVar (_, (ysubindex, _), (ysubvar, _)) ) ->
let c = SubScopeName.compare xsubindex ysubindex in
if c = 0 then ScopeVar.compare xsubvar ysubvar else c
| ToplevelVar (vx, _), ToplevelVar (vy, _) -> TopdefName.compare vx vy
| DesugaredScopeVar _, _ -> -1
| _, DesugaredScopeVar _ -> 1
| ScopelangScopeVar _, _ -> -1
| _, ScopelangScopeVar _ -> 1
| SubScopeVar _, _ -> .
| _, SubScopeVar _ -> .
| SubScopeVar _, _ -> -1
| _, SubScopeVar _ -> 1
| ToplevelVar _, _ -> .
| _, ToplevelVar _ -> .
let equal_location a b = compare_location a b = 0
let equal_except ex1 ex2 = ex1 = ex2
@ -710,34 +713,27 @@ let make_abs xs e taus pos =
let mark =
map_mark
(fun _ -> pos)
(fun ety ->
List.fold_right
(fun tx acc -> Marked.mark pos (TArrow (tx, acc)))
taus ety)
(fun ety -> Marked.mark pos (TArrow (taus, ety)))
(Marked.get_mark e)
in
eabs (bind xs e) taus mark
let make_app e u pos =
let make_app e args pos =
let mark =
fold_marks
(fun _ -> pos)
(function
| [] -> assert false
| fty :: argtys ->
List.fold_left
(fun tf tx ->
match Marked.unmark tf with
| TArrow (tx', tr) ->
assert (Type.unifiable tx.ty tx');
(* wrong arg type *)
tr
| TAny -> tf
| _ -> assert false)
fty.ty argtys)
(List.map Marked.get_mark (e :: u))
| fty :: argtys -> (
match Marked.unmark fty.ty with
| TArrow (tx', tr) ->
assert (Type.unifiable_list tx' (List.map (fun x -> x.ty) argtys));
tr
| TAny -> fty.ty
| _ -> assert false))
(List.map Marked.get_mark (e :: args))
in
eapp e u mark
eapp e args mark
let empty_thunked_term mark =
let silent = Var.make "_" in

6
compiler/shared_ast/expr.mli
View File

@ -43,10 +43,10 @@ val subst :
('a, 't) gexpr list ->
('a, 't) gexpr
val etuple : (lcalc, 't) boxed_gexpr list -> 't -> (lcalc, 't) boxed_gexpr
val etuple : ('a any, 't) boxed_gexpr list -> 't -> ('a, 't) boxed_gexpr
val etupleaccess :
(lcalc, 't) boxed_gexpr -> int -> int -> 't -> (lcalc, 't) boxed_gexpr
('a any, 't) boxed_gexpr -> int -> int -> 't -> ('a, 't) boxed_gexpr
val earray : ('a any, 't) boxed_gexpr list -> 't -> ('a, 't) boxed_gexpr
val elit : 'a any glit -> 't -> ('a, 't) boxed_gexpr
@ -304,7 +304,7 @@ val make_default :
- [<ex | false :- _>], when [ex] is a single exception, is rewritten as [ex] *)
val make_tuple :
(lcalc, 'm mark) boxed_gexpr list -> 'm mark -> (lcalc, 'm mark) boxed_gexpr
('a any, 'm mark) boxed_gexpr list -> 'm mark -> ('a, 'm mark) boxed_gexpr
(** Builds a tuple; the mark argument is only used as witness and for position
when building 0-uples *)

138
compiler/shared_ast/operator.ml
View File

@ -404,18 +404,19 @@ let translate :
| Eq_dur_dur -> Eq_dur_dur
let monomorphic_type (op, pos) =
let ( @- ) a b = TArrow ((TLit a, pos), b), pos in
let ( @-> ) a b = TArrow ((TLit a, pos), (TLit b, pos)), pos in
match op with
| Not -> TBool @-> TBool
| GetDay -> TDate @-> TInt
| GetMonth -> TDate @-> TInt
| GetYear -> TDate @-> TInt
| FirstDayOfMonth -> TDate @-> TDate
| LastDayOfMonth -> TDate @-> TDate
| And -> TBool @- TBool @-> TBool
| Or -> TBool @- TBool @-> TBool
| Xor -> TBool @- TBool @-> TBool
let args, ret =
match op with
| Not -> [TBool], TBool
| GetDay -> [TDate], TInt
| GetMonth -> [TDate], TInt
| GetYear -> [TDate], TInt
| FirstDayOfMonth -> [TDate], TDate
| LastDayOfMonth -> [TDate], TDate
| And -> [TBool; TBool], TBool
| Or -> [TBool; TBool], TBool
| Xor -> [TBool; TBool], TBool
in
TArrow (List.map (fun tau -> TLit tau, pos) args, (TLit ret, pos)), pos
(** Rules for overloads definitions:
@ -431,62 +432,63 @@ let monomorphic_type (op, pos) =
['a], ['b] and ['c], there should be a unique solution for the third. *)
let resolved_type (op, pos) =
let ( @- ) a b = TArrow ((TLit a, pos), b), pos in
let ( @-> ) a b = TArrow ((TLit a, pos), (TLit b, pos)), pos in
match op with
| Minus_int -> TInt @-> TInt
| Minus_rat -> TRat @-> TRat
| Minus_mon -> TMoney @-> TMoney
| Minus_dur -> TDuration @-> TDuration
| ToRat_int -> TInt @-> TRat
| ToRat_mon -> TMoney @-> TRat
| ToMoney_rat -> TRat @-> TMoney
| Round_rat -> TRat @-> TRat
| Round_mon -> TMoney @-> TMoney
| Add_int_int -> TInt @- TInt @-> TInt
| Add_rat_rat -> TRat @- TRat @-> TRat
| Add_mon_mon -> TMoney @- TMoney @-> TMoney
| Add_dat_dur -> TDate @- TDuration @-> TDate
| Add_dur_dur -> TDuration @- TDuration @-> TDuration
| Sub_int_int -> TInt @- TInt @-> TInt
| Sub_rat_rat -> TRat @- TRat @-> TRat
| Sub_mon_mon -> TMoney @- TMoney @-> TMoney
| Sub_dat_dat -> TDate @- TDate @-> TDuration
| Sub_dat_dur -> TDate @- TDuration @-> TDuration
| Sub_dur_dur -> TDuration @- TDuration @-> TDuration
| Mult_int_int -> TInt @- TInt @-> TInt
| Mult_rat_rat -> TRat @- TRat @-> TRat
| Mult_mon_rat -> TMoney @- TRat @-> TMoney
| Mult_dur_int -> TDuration @- TInt @-> TDuration
| Div_int_int -> TInt @- TInt @-> TRat
| Div_rat_rat -> TRat @- TRat @-> TRat
| Div_mon_mon -> TMoney @- TMoney @-> TRat
| Div_mon_rat -> TMoney @- TRat @-> TMoney
| Lt_int_int -> TInt @- TInt @-> TBool
| Lt_rat_rat -> TRat @- TRat @-> TBool
| Lt_mon_mon -> TMoney @- TMoney @-> TBool
| Lt_dat_dat -> TDate @- TDate @-> TBool
| Lt_dur_dur -> TDuration @- TDuration @-> TBool
| Lte_int_int -> TInt @- TInt @-> TBool
| Lte_rat_rat -> TRat @- TRat @-> TBool
| Lte_mon_mon -> TMoney @- TMoney @-> TBool
| Lte_dat_dat -> TDate @- TDate @-> TBool
| Lte_dur_dur -> TDuration @- TDuration @-> TBool
| Gt_int_int -> TInt @- TInt @-> TBool
| Gt_rat_rat -> TRat @- TRat @-> TBool
| Gt_mon_mon -> TMoney @- TMoney @-> TBool
| Gt_dat_dat -> TDate @- TDate @-> TBool
| Gt_dur_dur -> TDuration @- TDuration @-> TBool
| Gte_int_int -> TInt @- TInt @-> TBool
| Gte_rat_rat -> TRat @- TRat @-> TBool
| Gte_mon_mon -> TMoney @- TMoney @-> TBool
| Gte_dat_dat -> TDate @- TDate @-> TBool
| Gte_dur_dur -> TDuration @- TDuration @-> TBool
| Eq_int_int -> TInt @- TInt @-> TBool
| Eq_rat_rat -> TRat @- TRat @-> TBool
| Eq_mon_mon -> TMoney @- TMoney @-> TBool
| Eq_dat_dat -> TDate @- TDate @-> TBool
| Eq_dur_dur -> TDuration @- TDuration @-> TBool
let args, ret =
match op with
| Minus_int -> [TInt], TInt
| Minus_rat -> [TRat], TRat
| Minus_mon -> [TMoney], TMoney
| Minus_dur -> [TDuration], TDuration
| ToRat_int -> [TInt], TRat
| ToRat_mon -> [TMoney], TRat
| ToMoney_rat -> [TRat], TMoney
| Round_rat -> [TRat], TRat
| Round_mon -> [TMoney], TMoney
| Add_int_int -> [TInt; TInt], TInt
| Add_rat_rat -> [TRat; TRat], TRat
| Add_mon_mon -> [TMoney; TMoney], TMoney
| Add_dat_dur -> [TDate; TDuration], TDate
| Add_dur_dur -> [TDuration; TDuration], TDuration
| Sub_int_int -> [TInt; TInt], TInt
| Sub_rat_rat -> [TRat; TRat], TRat
| Sub_mon_mon -> [TMoney; TMoney], TMoney
| Sub_dat_dat -> [TDate; TDate], TDuration
| Sub_dat_dur -> [TDate; TDuration], TDuration
| Sub_dur_dur -> [TDuration; TDuration], TDuration
| Mult_int_int -> [TInt; TInt], TInt
| Mult_rat_rat -> [TRat; TRat], TRat
| Mult_mon_rat -> [TMoney; TRat], TMoney
| Mult_dur_int -> [TDuration; TInt], TDuration
| Div_int_int -> [TInt; TInt], TRat
| Div_rat_rat -> [TRat; TRat], TRat
| Div_mon_mon -> [TMoney; TMoney], TRat
| Div_mon_rat -> [TMoney; TRat], TMoney
| Lt_int_int -> [TInt; TInt], TBool
| Lt_rat_rat -> [TRat; TRat], TBool
| Lt_mon_mon -> [TMoney; TMoney], TBool
| Lt_dat_dat -> [TDate; TDate], TBool
| Lt_dur_dur -> [TDuration; TDuration], TBool
| Lte_int_int -> [TInt; TInt], TBool
| Lte_rat_rat -> [TRat; TRat], TBool
| Lte_mon_mon -> [TMoney; TMoney], TBool
| Lte_dat_dat -> [TDate; TDate], TBool
| Lte_dur_dur -> [TDuration; TDuration], TBool
| Gt_int_int -> [TInt; TInt], TBool
| Gt_rat_rat -> [TRat; TRat], TBool
| Gt_mon_mon -> [TMoney; TMoney], TBool
| Gt_dat_dat -> [TDate; TDate], TBool
| Gt_dur_dur -> [TDuration; TDuration], TBool
| Gte_int_int -> [TInt; TInt], TBool
| Gte_rat_rat -> [TRat; TRat], TBool
| Gte_mon_mon -> [TMoney; TMoney], TBool
| Gte_dat_dat -> [TDate; TDate], TBool
| Gte_dur_dur -> [TDuration; TDuration], TBool
| Eq_int_int -> [TInt; TInt], TBool
| Eq_rat_rat -> [TRat; TRat], TBool
| Eq_mon_mon -> [TMoney; TMoney], TBool
| Eq_dat_dat -> [TDate; TDate], TBool
| Eq_dur_dur -> [TDuration; TDuration], TBool
in
TArrow (List.map (fun tau -> TLit tau, pos) args, (TLit ret, pos)), pos
let resolve_overload_aux (op : ('a, overloaded) t) (operands : typ_lit list) :
('b, resolved) t * [ `Straight | `Reversed ] =

11
compiler/shared_ast/print.ml
View File

@ -66,6 +66,7 @@ let location (type a) (fmt : Format.formatter) (l : a glocation) : unit =
| SubScopeVar (_, subindex, subvar) ->
Format.fprintf fmt "%a.%a" SubScopeName.format_t (Marked.unmark subindex)
ScopeVar.format_t (Marked.unmark subvar)
| ToplevelVar v -> TopdefName.format_t fmt (Marked.unmark v)
let enum_constructor (fmt : Format.formatter) (c : EnumConstructor.t) : unit =
Cli.format_with_style [ANSITerminal.magenta] fmt
@ -112,9 +113,15 @@ let rec typ (ctx : decl_ctx option) (fmt : Format.formatter) (ty : typ) : unit =
(EnumConstructor.Map.bindings (EnumName.Map.find e ctx.ctx_enums))
punctuation "]")
| TOption t -> Format.fprintf fmt "@[<hov 2>%a@ %a@]" base_type "option" typ t
| TArrow (t1, t2) ->
Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" typ_with_parens t1 op_style "→"
| TArrow ([t1], t2) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@]" typ_with_parens t1 op_style "→"
typ t2
| TArrow (t1, t2) ->
Format.fprintf fmt "@[<hov 2>%a%a%a@ %a@ %a@]" op_style "("
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " op_style ",")
typ_with_parens)
t1 op_style ")" op_style "→" typ t2
| TArray t1 ->
Format.fprintf fmt "@[<hov 2>%a@ %a@]" base_type "collection" typ t1
| TAny -> base_type fmt "any"

30
compiler/shared_ast/program.ml
View File

@ -17,19 +17,19 @@
open Definitions
let map_exprs ~f ~varf { scopes; decl_ctx } =
let map_exprs ~f ~varf { code_items; decl_ctx } =
Bindlib.box_apply
(fun scopes -> { scopes; decl_ctx })
(Scope.map_exprs ~f ~varf scopes)
(fun code_items -> { code_items; decl_ctx })
(Scope.map_exprs ~f ~varf code_items)
let get_scope_body { scopes; _ } scope =
let get_scope_body { code_items; _ } scope =
match
Scope.fold_left ~init:None
~f:(fun acc scope_def _ ->
if ScopeName.equal scope_def.scope_name scope then
Some scope_def.scope_body
else acc)
scopes
~f:(fun acc item _ ->
match item with
| ScopeDef (name, body) when ScopeName.equal scope name -> Some body
| _ -> acc)
code_items
with
| None -> raise Not_found
| Some body -> body
@ -40,14 +40,14 @@ let untype : 'm. ('a, 'm mark) gexpr program -> ('a, untyped mark) gexpr program
let rec find_scope name vars = function
| Nil -> raise Not_found
| ScopeDef { scope_name; scope_body; _ } when scope_name = name ->
List.rev vars, scope_body
| ScopeDef { scope_next; _ } ->
let var, next = Bindlib.unbind scope_next in
| Cons (ScopeDef (n, body), _) when ScopeName.equal name n ->
List.rev vars, body
| Cons (_, next_bind) ->
let var, next = Bindlib.unbind next_bind in
find_scope name (var :: vars) next
let to_expr p main_scope =
let _, main_scope_body = find_scope main_scope [] p.scopes in
Scope.unfold p.decl_ctx p.scopes
let _, main_scope_body = find_scope main_scope [] p.code_items in
Scope.unfold p.decl_ctx p.code_items
(Scope.get_body_mark main_scope_body)
(ScopeName main_scope)

148
compiler/shared_ast/scope.ml
View File

@ -50,53 +50,72 @@ let map_exprs_in_lets :
Bindlib.box_apply (fun res -> Result res) (Expr.Box.lift (f res)))
scope_body_expr
let rec fold_left ~f ~init scopes =
match scopes with
let rec fold_left ~f ~init = function
| Nil -> init
| ScopeDef scope_def ->
let var, next = Bindlib.unbind scope_def.scope_next in
fold_left ~f ~init:(f init scope_def var) next
| Cons (item, next_bind) ->
let var, next = Bindlib.unbind next_bind in
fold_left ~f ~init:(f init item var) next
let rec fold_right ~f ~init scopes =
match scopes with
let rec fold_right ~f ~init = function
| Nil -> init
| ScopeDef scope_def ->
let var_next, next = Bindlib.unbind scope_def.scope_next in
| Cons (item, next_bind) ->
let var_next, next = Bindlib.unbind next_bind in
let result_next = fold_right ~f ~init next in
f scope_def var_next result_next
f item var_next result_next
let map ~f scopes =
fold_right
~f:(fun scope_def var_next acc ->
let new_def = f scope_def in
let new_next = Bindlib.bind_var var_next acc in
let rec map ~f ~varf = function
| Nil -> Bindlib.box Nil
| Cons (item, next_bind) ->
let item = f item in
let next_bind =
let var, next = Bindlib.unbind next_bind in
Bindlib.bind_var (varf var) (map ~f ~varf next)
in
Bindlib.box_apply2
(fun item next_bind -> Cons (item, next_bind))
item next_bind
let rec map_ctx ~f ~varf ctx = function
| Nil -> Bindlib.box Nil
| Cons (item, next_bind) ->
let ctx, item = f ctx item in
let next_bind =
let var, next = Bindlib.unbind next_bind in
Bindlib.bind_var (varf var) (map_ctx ~f ~varf ctx next)
in
Bindlib.box_apply2
(fun item next_bind -> Cons (item, next_bind))
item next_bind
let rec fold_map ~f ~varf ctx = function
| Nil -> ctx, Bindlib.box Nil
| Cons (item, next_bind) ->
let var, next = Bindlib.unbind next_bind in
let ctx, item = f ctx var item in
let ctx, next = fold_map ~f ~varf ctx next in
let next_bind = Bindlib.bind_var (varf var) next in
( ctx,
Bindlib.box_apply2
(fun new_def new_next ->
ScopeDef { new_def with scope_next = new_next })
new_def new_next)
~init:(Bindlib.box Nil) scopes
(fun item next_bind -> Cons (item, next_bind))
item next_bind )
let map_exprs ~f ~varf scopes =
fold_right
~f:(fun scope_def var_next acc ->
let scope_input_var, scope_lets =
Bindlib.unbind scope_def.scope_body.scope_body_expr
in
let f = function
| ScopeDef (name, body) ->
let scope_input_var, scope_lets = Bindlib.unbind body.scope_body_expr in
let new_body_expr = map_exprs_in_lets ~f ~varf scope_lets in
let new_body_expr =
Bindlib.bind_var (varf scope_input_var) new_body_expr
in
let new_next = Bindlib.bind_var (varf var_next) acc in
Bindlib.box_apply2
(fun scope_body_expr scope_next ->
ScopeDef
{
scope_def with
scope_body = { scope_def.scope_body with scope_body_expr };
scope_next;
})
new_body_expr new_next)
~init:(Bindlib.box Nil) scopes
Bindlib.box_apply
(fun scope_body_expr -> ScopeDef (name, { body with scope_body_expr }))
new_body_expr
| Topdef (name, typ, expr) ->
Bindlib.box_apply
(fun e -> Topdef (name, typ, e))
(Expr.Box.lift (f expr))
in
map ~f ~varf scopes
(* TODO: compute the expected body expr arrow type manually instead of [TAny]
for double-checking types ? *)
@ -136,7 +155,7 @@ let build_typ_from_sig
(pos : Pos.t) : typ =
let input_typ = Marked.mark pos (TStruct scope_input_struct_name) in
let result_typ = Marked.mark pos (TStruct scope_return_struct_name) in
Marked.mark pos (TArrow (input_typ, result_typ))
Marked.mark pos (TArrow ([input_typ], result_typ))
type 'e scope_name_or_var = ScopeName of ScopeName.t | ScopeVar of 'e Var.t
@ -164,7 +183,7 @@ let format
let rec unfold
(ctx : decl_ctx)
(s : 'e scopes)
(s : 'e code_item_list)
(mark : 'm mark)
(main_scope : 'expr scope_name_or_var) : 'e boxed =
match s with
@ -172,23 +191,31 @@ let rec unfold
match main_scope with
| ScopeVar v -> Expr.make_var v mark
| ScopeName _ -> failwith "should not happen")
| ScopeDef { scope_name; scope_body; scope_next } ->
let scope_var, scope_next = Bindlib.unbind scope_next in
let scope_pos = Marked.get_mark (ScopeName.get_info scope_name) in
let scope_body_mark = get_body_mark scope_body in
let main_scope =
match main_scope with
| ScopeVar v -> ScopeVar v
| ScopeName n ->
if ScopeName.compare n scope_name = 0 then ScopeVar scope_var
else ScopeName n
| Cons (item, next_bind) ->
let var, next = Bindlib.unbind next_bind in
let typ, expr, pos, is_main =
match item with
| ScopeDef (name, body) ->
let pos = Marked.get_mark (ScopeName.get_info name) in
let body_mark = get_body_mark body in
let is_main =
match main_scope with
| ScopeName n -> ScopeName.equal n name
| ScopeVar _ -> false
in
let typ =
build_typ_from_sig ctx body.scope_body_input_struct
body.scope_body_output_struct pos
in
let expr = to_expr ctx body body_mark in
typ, expr, pos, is_main
| Topdef (name, typ, expr) ->
let pos = Marked.get_mark (TopdefName.get_info name) in
typ, Expr.rebox expr, pos, false
in
Expr.make_let_in scope_var
(build_typ_from_sig ctx scope_body.scope_body_input_struct
scope_body.scope_body_output_struct scope_pos)
(to_expr ctx scope_body scope_body_mark)
(unfold ctx scope_next mark main_scope)
scope_pos
let main_scope = if is_main then ScopeVar var else main_scope in
let next = unfold ctx next mark main_scope in
Expr.make_let_in var typ expr next pos
let rec free_vars_body_expr scope_lets =
match scope_lets with
@ -198,14 +225,15 @@ let rec free_vars_body_expr scope_lets =
Var.Set.union (Expr.free_vars e)
(Var.Set.remove v (free_vars_body_expr body))
let free_vars_body scope_body =
let { scope_body_expr = binder; _ } = scope_body in
let v, body = Bindlib.unbind binder in
Var.Set.remove v (free_vars_body_expr body)
let free_vars_item = function
| ScopeDef (_, { scope_body_expr; _ }) ->
let v, body = Bindlib.unbind scope_body_expr in
Var.Set.remove v (free_vars_body_expr body)
| Topdef (_, _, expr) -> Expr.free_vars expr
let rec free_vars scopes =
match scopes with
| Nil -> Var.Set.empty
| ScopeDef { scope_body = body; scope_next = next; _ } ->
let v, next = Bindlib.unbind next in
Var.Set.union (Var.Set.remove v (free_vars next)) (free_vars_body body)
| Cons (item, next_bind) ->
let v, next = Bindlib.unbind next_bind in
Var.Set.union (Var.Set.remove v (free_vars next)) (free_vars_item item)

50
compiler/shared_ast/scope.mli
View File

@ -15,7 +15,8 @@
License for the specific language governing permissions and limitations under
the License. *)
(** Functions handling the scope structures of [shared_ast] *)
(** Functions handling the code item structures of [shared_ast], in particular
the scopes *)
open Catala_utils
open Definitions
@ -49,18 +50,18 @@ val map_exprs_in_lets :
'expr2 scope_body_expr Bindlib.box
val fold_left :
f:('a -> 'expr1 scope_def -> 'expr1 Var.t -> 'a) ->
f:('a -> 'expr1 code_item -> 'expr1 Var.t -> 'a) ->
init:'a ->
'expr1 scopes ->
'expr1 code_item_list ->
'a
(** Usage: [fold_left ~f:(fun acc scope_def scope_var -> ...) ~init scope_def],
where [scope_var] is the variable bound to the scope in the next scopes to
be examined. *)
(** Usage: [fold_left ~f:(fun acc code_def code_var -> ...) ~init code_def],
where [code_var] is the variable bound to the code item in the next code
items to be examined. *)
val fold_right :
f:('expr1 scope_def -> 'expr1 Var.t -> 'a -> 'a) ->
f:('expr1 code_item -> 'expr1 Var.t -> 'a -> 'a) ->
init:'a ->
'expr1 scopes ->
'expr1 code_item_list ->
'a
(** Usage:
[fold_right_scope ~f:(fun scope_def scope_var acc -> ...) ~init scope_def],
@ -68,15 +69,32 @@ val fold_right :
be examined (which are before in the program order). *)
val map :
f:('e scope_def -> 'e scope_def Bindlib.box) ->
'e scopes ->
'e scopes Bindlib.box
f:('e1 code_item -> 'e2 code_item Bindlib.box) ->
varf:('e1 Var.t -> 'e2 Var.t) ->
'e1 code_item_list ->
'e2 code_item_list Bindlib.box
val map_ctx :
f:('ctx -> 'e1 code_item -> 'ctx * 'e2 code_item Bindlib.box) ->
varf:('e1 Var.t -> 'e2 Var.t) ->
'ctx ->
'e1 code_item_list ->
'e2 code_item_list Bindlib.box
(** Similar to [map], but a context is passed left-to-right through the given
function *)
val fold_map :
f:('ctx -> 'e1 Var.t -> 'e1 code_item -> 'ctx * 'e2 code_item Bindlib.box) ->
varf:('e1 Var.t -> 'e2 Var.t) ->
'ctx ->
'e1 code_item_list ->
'ctx * 'e2 code_item_list Bindlib.box
val map_exprs :
f:('expr1 -> 'expr2 boxed) ->
varf:('expr1 Var.t -> 'expr2 Var.t) ->
'expr1 scopes ->
'expr2 scopes Bindlib.box
'expr1 code_item_list ->
'expr2 code_item_list Bindlib.box
(** This is the main map visitor for all the expressions inside all the scopes
of the program. *)
@ -103,7 +121,7 @@ type 'e scope_name_or_var = ScopeName of ScopeName.t | ScopeVar of 'e Var.t
val unfold :
decl_ctx ->
((_, 'm mark) gexpr as 'e) scopes ->
((_, 'm mark) gexpr as 'e) code_item_list ->
'm mark ->
'e scope_name_or_var ->
'e boxed
@ -116,5 +134,5 @@ val build_typ_from_sig :
(** {2 Analysis and tests} *)
val free_vars_body_expr : 'e scope_body_expr -> 'e Var.Set.t
val free_vars_body : 'e scope_body -> 'e Var.Set.t
val free_vars : 'e scopes -> 'e Var.Set.t
val free_vars_item : 'e code_item -> 'e Var.Set.t
val free_vars : 'e code_item_list -> 'e Var.Set.t

7
compiler/shared_ast/type.ml
View File

@ -29,7 +29,7 @@ let rec equal ty1 ty2 =
| TStruct n1, TStruct n2 -> StructName.equal n1 n2
| TEnum n1, TEnum n2 -> EnumName.equal n1 n2
| TOption t1, TOption t2 -> equal t1 t2
| TArrow (t1, t1'), TArrow (t2, t2') -> equal t1 t2 && equal t1' t2'
| TArrow (t1, t1'), TArrow (t2, t2') -> equal_list t1 t2 && equal t1' t2'
| TArray t1, TArray t2 -> equal t1 t2
| TAny, TAny -> true
| ( ( TLit _ | TTuple _ | TStruct _ | TEnum _ | TOption _ | TArrow _
@ -49,7 +49,8 @@ let rec unifiable ty1 ty2 =
| TStruct n1, TStruct n2 -> StructName.equal n1 n2
| TEnum n1, TEnum n2 -> EnumName.equal n1 n2
| TOption t1, TOption t2 -> unifiable t1 t2
| TArrow (t1, t1'), TArrow (t2, t2') -> unifiable t1 t2 && unifiable t1' t2'
| TArrow (t1, t1'), TArrow (t2, t2') ->
unifiable_list t1 t2 && unifiable t1' t2'
| TArray t1, TArray t2 -> unifiable t1 t2
| ( (TLit _ | TTuple _ | TStruct _ | TEnum _ | TOption _ | TArrow _ | TArray _),
_ ) ->
@ -66,7 +67,7 @@ let rec compare ty1 ty2 =
| TEnum en1, TEnum en2 -> EnumName.compare en1 en2
| TOption t1, TOption t2 -> compare t1 t2
| TArrow (a1, b1), TArrow (a2, b2) -> (
match compare a1 a2 with 0 -> compare b1 b2 | n -> n)
match List.compare compare a1 a2 with 0 -> compare b1 b2 | n -> n)
| TArray t1, TArray t2 -> compare t1 t2
| TAny, TAny -> 0
| TLit _, _ -> -1

3
compiler/shared_ast/type.mli
View File

@ -19,8 +19,9 @@ type t = Definitions.typ
val equal : t -> t -> bool
val equal_list : t list -> t list -> bool
val compare : t -> t -> int
val unifiable : t -> t -> bool
val unifiable_list : t list -> t list -> bool
(** Similar to [equal], but allows TAny holes *)
val arrow_return : t -> t

132
compiler/shared_ast/typing.ml
View File

@ -39,7 +39,7 @@ type unionfind_typ = naked_typ Marked.pos UnionFind.elem
and naked_typ =
| TLit of A.typ_lit
| TArrow of unionfind_typ * unionfind_typ
| TArrow of unionfind_typ list * unionfind_typ
| TTuple of unionfind_typ list
| TStruct of A.StructName.t
| TEnum of A.EnumName.t
@ -56,7 +56,7 @@ let rec typ_to_ast ?(unsafe = false) (ty : unionfind_typ) : A.typ =
| TStruct s -> A.TStruct s, pos
| TEnum e -> A.TEnum e, pos
| TOption t -> A.TOption (typ_to_ast t), pos
| TArrow (t1, t2) -> A.TArrow (typ_to_ast t1, typ_to_ast t2), pos
| TArrow (t1, t2) -> A.TArrow (List.map typ_to_ast t1, typ_to_ast t2), pos
| TArray t1 -> A.TArray (typ_to_ast t1), pos
| TAny _ ->
if unsafe then A.TAny, pos
@ -73,14 +73,14 @@ let rec all_resolved ty =
| TAny _ -> false
| TLit _ | TStruct _ | TEnum _ -> true
| TOption t1 | TArray t1 -> all_resolved t1
| TArrow (t1, t2) -> all_resolved t1 && all_resolved t2
| TArrow (t1, t2) -> List.for_all all_resolved t1 && all_resolved t2
| TTuple ts -> List.for_all all_resolved ts
let rec ast_to_typ (ty : A.typ) : unionfind_typ =
let ty' =
match Marked.unmark ty with
| A.TLit l -> TLit l
| A.TArrow (t1, t2) -> TArrow (ast_to_typ t1, ast_to_typ t2)
| A.TArrow (t1, t2) -> TArrow (List.map ast_to_typ t1, ast_to_typ t2)
| A.TTuple ts -> TTuple (List.map ast_to_typ ts)
| A.TStruct s -> TStruct s
| A.TEnum e -> TEnum e
@ -118,9 +118,15 @@ let rec format_typ
| TEnum e -> Format.fprintf fmt "%a" A.EnumName.format_t e
| TOption t ->
Format.fprintf fmt "@[<hov 2>%a@ %s@]" format_typ_with_parens t "eoption"
| TArrow (t1, t2) ->
Format.fprintf fmt "@[<hov 2>%a →@ %a@]" format_typ_with_parens t1
| TArrow ([t1], t2) ->
Format.fprintf fmt "@[<hov 2>%a@ →@ %a@]" format_typ_with_parens t1
format_typ t2
| TArrow (t1, t2) ->
Format.fprintf fmt "@[<hov 2>(%a)@ →@ %a@]"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
format_typ_with_parens)
t1 format_typ t2
| TArray t1 -> (
match Marked.unmark (UnionFind.get (UnionFind.find t1)) with
| TAny _ when not !Cli.debug_flag -> Format.pp_print_string fmt "collection"
@ -149,12 +155,13 @@ let rec unify
let () =
match Marked.unmark t1_repr, Marked.unmark t2_repr with
| TLit tl1, TLit tl2 -> if tl1 <> tl2 then raise_type_error ()
| TArrow (t11, t12), TArrow (t21, t22) ->
| TArrow (t11, t12), TArrow (t21, t22) -> (
unify e t12 t22;
unify e t11 t21
| TTuple ts1, TTuple ts2 ->
if List.length ts1 = List.length ts2 then List.iter2 (unify e) ts1 ts2
else raise_type_error ()
try List.iter2 (unify e) t11 t21
with Invalid_argument _ -> raise_type_error ())
| TTuple ts1, TTuple ts2 -> (
try List.iter2 (unify e) ts1 ts2
with Invalid_argument _ -> raise_type_error ())
| TStruct s1, TStruct s2 ->
if not (A.StructName.equal s1 s2) then raise_type_error ()
| TEnum e1, TEnum e2 ->
@ -240,19 +247,19 @@ let polymorphic_op_type (op : ('a, Operator.polymorphic) A.operator Marked.pos)
let it = lazy (UnionFind.make (TLit TInt, pos)) in
let array a = lazy (UnionFind.make (TArray (Lazy.force a), pos)) in
let ( @-> ) x y =
lazy (UnionFind.make (TArrow (Lazy.force x, Lazy.force y), pos))
lazy (UnionFind.make (TArrow (List.map Lazy.force x, Lazy.force y), pos))
in
let ty =
match Marked.unmark op with
| Fold -> (any2 @-> any @-> any2) @-> any2 @-> array any @-> any2
| Eq -> any @-> any @-> bt
| Map -> (any @-> any2) @-> array any @-> array any2
| Filter -> (any @-> bt) @-> array any @-> array any
| Reduce -> (any @-> any @-> any) @-> any @-> array any @-> any
| Concat -> array any @-> array any @-> array any
| Log (PosRecordIfTrueBool, _) -> bt @-> bt
| Log _ -> any @-> any
| Length -> array any @-> it
| Fold -> [[any2; any] @-> any2; any2; array any] @-> any2
| Eq -> [any; any] @-> bt
| Map -> [[any] @-> any2; array any] @-> array any2
| Filter -> [[any] @-> bt; array any] @-> array any
| Reduce -> [[any; any] @-> any; any; array any] @-> any
| Concat -> [array any; array any] @-> array any
| Log (PosRecordIfTrueBool, _) -> [bt] @-> bt
| Log _ -> [any] @-> any
| Length -> [array any] @-> it
in
Lazy.force ty
@ -276,6 +283,7 @@ module Env = struct
vars : ('e, unionfind_typ) Var.Map.t;
scope_vars : A.typ A.ScopeVar.Map.t;
scopes : A.typ A.ScopeVar.Map.t A.ScopeName.Map.t;
toplevel_vars : A.typ A.TopdefName.Map.t;
}
let empty =
@ -283,10 +291,12 @@ module Env = struct
vars = Var.Map.empty;
scope_vars = A.ScopeVar.Map.empty;
scopes = A.ScopeName.Map.empty;
toplevel_vars = A.TopdefName.Map.empty;
}
let get t v = Var.Map.find_opt v t.vars
let get_scope_var t sv = A.ScopeVar.Map.find_opt sv t.scope_vars
let get_toplevel_var t v = A.TopdefName.Map.find_opt v t.toplevel_vars
let get_subscope_out_var t scope var =
Option.bind (A.ScopeName.Map.find_opt scope t.scopes) (fun vmap ->
@ -301,6 +311,9 @@ module Env = struct
let add_scope scope_name ~vars t =
{ t with scopes = A.ScopeName.Map.add scope_name vars t.scopes }
let add_toplevel_var v typ t =
{ t with toplevel_vars = A.TopdefName.Map.add v typ t.toplevel_vars }
let open_scope scope_name t =
let scope_vars =
A.ScopeVar.Map.union
@ -361,6 +374,7 @@ and typecheck_expr_top_down :
Env.get_scope_var env (Marked.unmark v)
| SubScopeVar (scope, _, v) ->
Env.get_subscope_out_var env scope (Marked.unmark v)
| ToplevelVar v -> Env.get_toplevel_var env (Marked.unmark v)
in
let ty =
match ty_opt with
@ -505,7 +519,10 @@ and typecheck_expr_top_down :
A.EnumConstructor.Map.mapi
(fun c_name e ->
let c_ty = A.EnumConstructor.Map.find c_name cases_ty in
let e_ty = unionfind ~pos:e (TArrow (ast_to_typ c_ty, t_ret)) in
(* For now our constructors are limited to zero or one argument. If
there is a change to allow for multiple arguments, it might be
easier to use tuples directly. *)
let e_ty = unionfind ~pos:e (TArrow ([ast_to_typ c_ty], t_ret)) in
typecheck_expr_top_down ctx env e_ty e)
cases
in
@ -564,11 +581,7 @@ and typecheck_expr_top_down :
else
let tau_args = List.map ast_to_typ t_args in
let t_ret = unionfind (TAny (Any.fresh ())) in
let t_func =
List.fold_right
(fun t_arg acc -> unionfind (TArrow (t_arg, acc)))
tau_args t_ret
in
let t_func = unionfind (TArrow (tau_args, t_ret)) in
let mark = uf_mark t_func in
assert (List.for_all all_resolved tau_args);
let xs, body = Bindlib.unmbind binder in
@ -583,11 +596,7 @@ and typecheck_expr_top_down :
Expr.eabs binder' (List.map typ_to_ast tau_args) mark
| A.EApp { f = (EOp { op; tys }, _) as e1; args } ->
let t_args = List.map ast_to_typ tys in
let t_func =
List.fold_right
(fun t_arg acc -> unionfind (TArrow (t_arg, acc)))
t_args tau
in
let t_func = unionfind (TArrow (t_args, tau)) in
let e1', args' =
Operator.kind_dispatch op
~polymorphic:(fun _ ->
@ -623,22 +632,14 @@ and typecheck_expr_top_down :
of the arguments if [f] is [EAbs] before disambiguation. This is also the
right order for the [let-in] form. *)
let t_args = List.map (fun _ -> unionfind (TAny (Any.fresh ()))) args in
let t_func =
List.fold_right
(fun t_arg acc -> unionfind (TArrow (t_arg, acc)))
t_args tau
in
let t_func = unionfind (TArrow (t_args, tau)) in
let args' = List.map2 (typecheck_expr_top_down ctx env) t_args args in
let e1' = typecheck_expr_top_down ctx env t_func e1 in
Expr.eapp e1' args' context_mark
| A.EOp { op; tys } ->
let tys' = List.map ast_to_typ tys in
let t_ret = unionfind (TAny (Any.fresh ())) in
let t_func =
List.fold_right
(fun t_arg acc -> unionfind (TArrow (t_arg, acc)))
tys' t_ret
in
let t_func = unionfind (TArrow (tys', t_ret)) in
unify ctx e t_func tau;
let tys, mark =
Operator.kind_dispatch op
@ -777,32 +778,39 @@ let scope_body ctx env body =
let var, e = Bindlib.unbind body.A.scope_body_expr in
let env = Env.add var ty_in env in
let e' = scope_body_expr ctx env ty_out e in
( Bindlib.bind_var (Var.translate var) e',
( Bindlib.box_apply
(fun scope_body_expr -> { body with scope_body_expr })
(Bindlib.bind_var (Var.translate var) e'),
UnionFind.make
(Marked.mark
(get_pos body.A.scope_body_output_struct)
(TArrow (ty_in, ty_out))) )
(TArrow ([ty_in], ty_out))) )
let rec scopes ctx env = function
| A.Nil -> Bindlib.box A.Nil
| A.ScopeDef def ->
let body_e, ty_scope = scope_body ctx env def.scope_body in
let scope_next =
let scope_var, next = Bindlib.unbind def.scope_next in
let env = Env.add scope_var ty_scope env in
let next' = scopes ctx env next in
Bindlib.bind_var (Var.translate scope_var) next'
| A.Cons (item, next_bind) ->
let var, next = Bindlib.unbind next_bind in
let env, def =
match item with
| A.ScopeDef (name, body) ->
let body_e, ty_scope = scope_body ctx env body in
( Env.add var ty_scope env,
Bindlib.box_apply (fun body -> A.ScopeDef (name, body)) body_e )
| A.Topdef (name, typ, e) ->
let e' = expr_raw ctx ~env ~typ e in
let uf = (Marked.get_mark e').uf in
let e' = Expr.map_marks ~f:get_ty_mark e' in
( Env.add var uf env,
Bindlib.box_apply
(fun e -> A.Topdef (name, typ, e))
(Expr.Box.lift e') )
in
Bindlib.box_apply2
(fun scope_body_expr scope_next ->
A.ScopeDef
{
def with
scope_body = { def.scope_body with scope_body_expr };
scope_next;
})
body_e scope_next
let next' = scopes ctx env next in
let next_bind' = Bindlib.bind_var (Var.translate var) next' in
Bindlib.box_apply2 (fun item next -> A.Cons (item, next)) def next_bind'
let program prg =
let scopes = Bindlib.unbox (scopes prg.A.decl_ctx Env.empty prg.A.scopes) in
{ prg with scopes }
let code_items =
Bindlib.unbox (scopes prg.A.decl_ctx Env.empty prg.A.code_items)
in
{ prg with code_items }

1
compiler/shared_ast/typing.mli
View File

@ -24,6 +24,7 @@ module Env : sig
val empty : 'e t
val add_var : 'e Var.t -> typ -> 'e t -> 'e t
val add_toplevel_var : TopdefName.t -> typ -> 'e t -> 'e t
val add_scope_var : ScopeVar.t -> typ -> 'e t -> 'e t
val add_scope : ScopeName.t -> vars:typ ScopeVar.Map.t -> 'e t -> 'e t
val open_scope : ScopeName.t -> 'e t -> 'e t

34
compiler/surface/ast.ml
View File

@ -433,7 +433,7 @@ and naked_expression =
| CollectionOp of collection_op * expression
| MemCollection of expression * expression
| TestMatchCase of expression * match_case_pattern Marked.pos
| FunCall of expression * expression
| FunCall of expression * expression list
| ScopeCall of
(path * uident Marked.pos) Marked.pos
* (lident Marked.pos * expression) list
@ -737,17 +737,46 @@ type scope_decl = {
name = "scope_decl_iter";
}]
type top_def = {
topdef_name : lident Marked.pos;
topdef_args : (lident Marked.pos * base_typ_data Marked.pos) list;
(** Empty list if this is not a function *)
topdef_type : base_typ_data Marked.pos;
(** Output type if this is a function *)
topdef_expr : expression;
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["lident_map"; "typ_map"; "expression_map"];
name = "top_def_map";
},
visitors
{
variety = "iter";
ancestors = ["lident_iter"; "typ_iter"; "expression_iter"];
name = "top_def_iter";
}]
type code_item =
| ScopeUse of scope_use
| ScopeDecl of scope_decl
| StructDecl of struct_decl
| EnumDecl of enum_decl
| Topdef of top_def
[@@deriving
visitors
{
variety = "map";
ancestors =
["scope_decl_map"; "enum_decl_map"; "struct_decl_map"; "scope_use_map"];
[
"scope_decl_map";
"enum_decl_map";
"struct_decl_map";
"scope_use_map";
"top_def_map";
];
name = "code_item_map";
},
visitors
@ -759,6 +788,7 @@ type code_item =
"enum_decl_iter";
"struct_decl_iter";
"scope_use_iter";
"top_def_iter";
];
name = "code_item_iter";
}]

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

@ -601,14 +601,16 @@ let rec lex_code (lexbuf : lexbuf) : token =
Buffer.add_string cents (String.make (2 - Buffer.length cents) '0');
L.update_acc lexbuf;
MONEY_AMOUNT (Buffer.contents units, Buffer.contents cents)
| Rep (digit, 4), '-', Rep (digit, 2), '-', Rep (digit, 2) ->
| '|', Rep (digit, 4), '-', Rep (digit, 2), '-', Rep (digit, 2), '|' ->
let rex =
Re.(compile @@ whole_string @@ seq [
char '|';
group (repn digit 4 None);
char '-';
group (repn digit 2 None);
char '-';
group (repn digit 2 None);
char '|';
])
in
let date_parts = R.get_substring (R.exec ~rex (Utf8.lexeme lexbuf)) in
@ -687,9 +689,6 @@ let rec lex_code (lexbuf : lexbuf) : token =
| ']' ->
L.update_acc lexbuf;
RBRACKET
| '|' ->
L.update_acc lexbuf;
BAR
| ':' ->
L.update_acc lexbuf;
COLON
@ -705,6 +704,9 @@ let rec lex_code (lexbuf : lexbuf) : token =
| '.' ->
L.update_acc lexbuf;
DOT
| ',' ->
L.update_acc lexbuf;
COMMA
| uppercase, Star (uppercase | lowercase | digit | '_' | '\'') ->
(* Name of constructor *)
L.update_acc lexbuf;

1
compiler/surface/lexer_common.ml
View File

@ -84,7 +84,6 @@ let token_list_language_agnostic : (string * token) list =
"-", MINUS KPoly;
"*", MULT KPoly;
"/", DIV KPoly;
"|", BAR;
":", COLON;
";", SEMICOLON;
"--", ALT;

3441
compiler/surface/parser.messages
View File

File diff suppressed because it is too large Load Diff

31
compiler/surface/parser.mly
View File

@ -38,6 +38,7 @@ end>
%left PLUS MINUS PLUSPLUS
%left MULT DIV
%right apply OF CONTAINS FOR SUCH WITH
%right COMMA
%right unop_expr
%right CONTENT
%nonassoc UIDENT
@ -181,9 +182,9 @@ let naked_expression ==
| e = struct_or_enum_inject ; <>
| e1 = expression ;
OF ;
e2 = expression ; {
FunCall (e1, e2)
} %prec apply
args = funcall_args ; {
FunCall (e1, args)
}
| OUTPUT ; OF ;
c = addpos(quident) ;
fields = option(scope_call_args) ; {
@ -303,7 +304,7 @@ let literal :=
money_amount_cents = cents;
}
}
| BAR ; d = DATE_LITERAL ; BAR ; {
| d = DATE_LITERAL ; {
let (y,m,d) = d in
LDate {
literal_date_year = y;
@ -322,6 +323,10 @@ let scope_call_args ==
fields
}
let funcall_args :=
| e = expression; { [e] } %prec apply
| e = expression; COMMA; el = funcall_args ; { e :: el }
let minmax ==
| MAXIMUM ; { true }
| MINIMUM ; { false }
@ -596,6 +601,13 @@ let enum_decl_line :=
}
}
let var_content ==
| ~ = lident ; CONTENT ; ty = addpos(typ) ; <>
let depends_stance ==
| DEPENDS ; args = separated_nonempty_list(COMMA,var_content) ; <>
| DEPENDS ; LPAREN ; args = separated_nonempty_list(COMMA,var_content) ; RPAREN ; <>
| { [] }
let code_item :=
| SCOPE ; c = uident ;
e = option(preceded(UNDER_CONDITION,expression)) ;
@ -627,6 +639,17 @@ let code_item :=
enum_decl_cases = cases;
}
}
| DECLARATION ; name = lident ;
CONTENT ; ty = addpos(typ) ;
args = depends_stance ;
DEFINED_AS ; e = expression ; {
Topdef {
topdef_name = name;
topdef_args = args;
topdef_type = ty;
topdef_expr = e;
}
}
let code :=
| code = list(addpos(code_item)) ; <>

4
compiler/surface/tokens.mly
View File

@ -37,11 +37,11 @@
%token<string * string> DECIMAL_LITERAL
%token<string * string> MONEY_AMOUNT
%token BEGIN_CODE TEXT
%token COLON ALT DATA BAR
%token COLON ALT DATA
%token OF INTEGER COLLECTION CONTAINS AMONG
%token RULE CONDITION DEFINED_AS
%token<Ast.op_kind> LESSER GREATER LESSER_EQUAL GREATER_EQUAL
%token LET EXISTS IN SUCH THAT
%token LET EXISTS IN SUCH THAT COMMA
%token DOT AND OR XOR LPAREN RPAREN EQUAL
%token CARDINAL ASSERTION FIXED BY YEAR MONTH DAY
%token<Ast.op_kind> PLUS MINUS MULT DIV

90
compiler/verification/conditions.ml
View File

@ -401,54 +401,62 @@ let rec generate_verification_conditions_scope_body_expr
in
new_ctx, vc_list @ new_vcs, assert_list @ new_asserts
let rec generate_verification_conditions_scopes
let generate_verification_conditions_code_items
(decl_ctx : decl_ctx)
(scopes : 'm expr scopes)
(code_items : 'm expr code_item_list)
(s : ScopeName.t option) : verification_condition list =
match scopes with
| Nil -> []
| ScopeDef scope_def ->
let is_selected_scope =
match s with
| Some s when ScopeName.compare s scope_def.scope_name = 0 -> true
| None -> true
| _ -> false
in
let vcs =
if is_selected_scope then
let _scope_input_var, scope_body_expr =
Bindlib.unbind scope_def.scope_body.scope_body_expr
Scope.fold_left
~f:(fun vcs item _ ->
match item with
| Topdef _ -> []
| ScopeDef (name, body) ->
let is_selected_scope =
match s with
| Some s when ScopeName.equal s name -> true
| None -> true
| _ -> false
in
let ctx =
{
current_scope_name = scope_def.scope_name;
decl = decl_ctx;
input_vars = [];
scope_variables_typs =
Var.Map.empty
(* We don't need to add the typ of the scope input var here
because it will never appear in an expression for which we
generate a verification conditions (the big struct is
destructured with a series of let bindings just after. )*);
}
let new_vcs =
if is_selected_scope then
let _scope_input_var, scope_body_expr =
Bindlib.unbind body.scope_body_expr
in
let ctx =
{
current_scope_name = name;
decl = decl_ctx;
input_vars = [];
scope_variables_typs =
Var.Map.empty
(* We don't need to add the typ of the scope input var here
because it will never appear in an expression for which we
generate a verification conditions (the big struct is
destructured with a series of let bindings just after. )*);
}
in
let _, vcs, asserts =
generate_verification_conditions_scope_body_expr ctx
scope_body_expr
in
let combined_assert =
conjunction_exprs asserts
(Typed
{
pos = Pos.no_pos;
ty = Marked.mark Pos.no_pos (TLit TBool);
})
in
List.map (fun vc -> { vc with vc_asserts = combined_assert }) vcs
else []
in
let _, vcs, asserts =
generate_verification_conditions_scope_body_expr ctx scope_body_expr
in
let combined_assert =
conjunction_exprs asserts
(Typed
{ pos = Pos.no_pos; ty = Marked.mark Pos.no_pos (TLit TBool) })
in
List.map (fun vc -> { vc with vc_asserts = combined_assert }) vcs
else []
in
let _scope_var, next = Bindlib.unbind scope_def.scope_next in
generate_verification_conditions_scopes decl_ctx next s @ vcs
new_vcs @ vcs)
~init:[] code_items
let generate_verification_conditions (p : 'm program) (s : ScopeName.t option) :
verification_condition list =
let vcs = generate_verification_conditions_scopes p.decl_ctx p.scopes s in
let vcs =
generate_verification_conditions_code_items p.decl_ctx p.code_items s
in
(* We sort this list by scope name and then variable name to ensure consistent
output for testing*)
List.sort

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

@ -405,10 +405,12 @@ let find_or_create_funcdecl (ctx : context) (v : typed expr Var.t) (ty : typ) :
| None -> (
match Marked.unmark ty with
| TArrow (t1, t2) ->
let ctx, z3_t1 = translate_typ ctx (Marked.unmark t1) in
let ctx, z3_t1 =
List.fold_left_map translate_typ ctx (List.map Marked.unmark t1)
in
let ctx, z3_t2 = translate_typ ctx (Marked.unmark t2) in
let name = unique_name v in
let fd = FuncDecl.mk_func_decl_s ctx.ctx_z3 name [z3_t1] z3_t2 in
let fd = FuncDecl.mk_func_decl_s ctx.ctx_z3 name z3_t1 z3_t2 in
let ctx = add_funcdecl v fd ctx in
let ctx = add_z3var name v ty ctx in
ctx, fd
@ -676,6 +678,8 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
in
let ctx, s = translate_expr ctx e in
ctx, Expr.mk_app ctx.ctx_z3 accessor [s]
| ETuple _ -> failwith "[Z3 encoding] ETuple unsupported"
| ETupleAccess _ -> failwith "[Z3 encoding] ETupleAccess unsupported"
| EInj { e; cons; name } ->
(* This node corresponds to creating a value for the enumeration [en], by
calling the [idx]-th constructor of enum [en], with argument [e] *)

BIN
doc/syntax/syntax.pdf
View File

Binary file not shown.

9
doc/syntax/syntax_en.tex
View File

@ -358,6 +358,7 @@
match expr with pattern
-- Case1 of x: ...
-- Case2 : ...
-- anything : ...
```
\end{catala}
\\
@ -389,7 +390,7 @@
\\
Direct scope call & \begin{catala}
```catala
outut of Scope1
output of Scope1
with { -- fld1: 9 -- fld2: true }
```
\end{catala}
@ -444,9 +445,9 @@
\\
State transitions declaration & \begin{catala}
```catala
internal var1 content ...
state before
state after
internal var1 content ...
state before
state after
```
\end{catala}
\\

9
doc/syntax/syntax_fr.tex
View File

@ -364,6 +364,7 @@
selon expr sous forme
-- Cas1 de x: ...
-- Cas2 : ...
-- n'importe quel : ...
```
\end{catala}
\\
@ -422,7 +423,7 @@
\\
Déclaration d'énumération & \begin{catala}
```catala
déclaration énumeration Énum1:
déclaration énumération Énum1:
-- Cas1 contenu entier
-- Cas2
```
@ -450,9 +451,9 @@
\\
Transitions d'état & \begin{catala}
```catala
interne var1 contenu ...
état avant
état après
interne var1 contenu ...
état avant
état après
```
\end{catala}
\\

4
examples/Makefile.common.mk
View File

@ -20,11 +20,11 @@ help : ../Makefile.common.mk
#> SCOPE=<ScopeName> <target_file>.run : Runs the interpeter for the scope of the file
%.run: %.catala_$(CATALA_LANG)
@$(CATALA) Makefile $<
@$(CATALA) Makefile $(CURR_DIR)$<
$(CATALA) \
Interpret \
-s $(SCOPE) \
$<
$(CURR_DIR)$<
#> <target_file>.ml : Compiles the file to OCaml
%.ml: %.catala_$(CATALA_LANG)

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

@ -29,7 +29,7 @@ scope Test1:
```catala-test-inline
$ catala Interpret -s Test1
[ERROR] Syntax error at token "scope"
Message: unexpected token
Message: expected either 'condition', or 'content' followed by the expected variable type
Autosuggestion: did you mean "content", or maybe "condition"?
Error token:
@ -73,7 +73,7 @@ scope Test2:
```catala-test-inline
$ catala Interpret -s Test2
[ERROR] Syntax error at token "scope"
Message: unexpected token
Message: expected either 'condition', or 'content' followed by the expected variable type
Autosuggestion: did you mean "content", or maybe "condition"?
Error token:
@ -117,7 +117,7 @@ scope Test3:
```catala-test-inline
$ catala Interpret -s Test3
[ERROR] Syntax error at token "scope"
Message: unexpected token
Message: expected either 'condition', or 'content' followed by the expected variable type
Autosuggestion: did you mean "content", or maybe "condition"?
Error token:
@ -163,7 +163,7 @@ scope Test4:
```catala-test-inline
$ catala Interpret -s Test4
[ERROR] Syntax error at token "scope"
Message: unexpected token
Message: expected either 'condition', or 'content' followed by the expected variable type
Autosuggestion: did you mean "content", or maybe "condition"?
Error token:

153
examples/tutorial_en/tutorial_en.catala_en
View File

@ -843,3 +843,156 @@ There is no single way to write Catala programs, as the program style should be
adapted to the legislation it annotates. However, Catala is a functional
language at heart, so following standard functional programming design patterns
should help achieve concise and readable code.
# Annex A: top-level value definitions
Toplevel definitions provide a way to define values or functions directly in the
program, without putting them in a scope. This is useful for constants or helper
functions, as shown in the examples below.
Toplevel definitions are available by name throughout the program ; they can
depend on each other (as long as there are no cycles), but are not allowed to
rely on any scope evaluations.
## Example 1: toplevel constants
### A. Using only scope definitions
a. Throughout this corpus, the number of workdays per week is assumed to be 5.
```catala
declaration scope WorkdaysPerWeek:
output value content integer
scope WorkdaysPerWeek:
definition value equals 5
# Requiring to declare the scope with just an output variable is quite cumbersome, and impedes readability
```
b. The General Lunch Allocation is $2 per workday, over the number of work weeks.
```catala
declaration scope LunchAllocation_A:
input number_of_work_weeks content integer
workdays_per_week scope WorkdaysPerWeek
# The subscope needs to be declared just to access its value.
# Note that in some cases it may be a good thing to have that dependency
# explicit
output value content money
scope LunchAllocation_A:
definition value equals
$2 * (number_of_work_weeks * workdays_per_week.value / 7)
# The value requires <scope_name>.<variable_name> to be accessed
```
### B. Using toplevel definitions
a. Throughout this corpus, the number of workdays per week is assumed to be 5.
```catala
declaration workdays_per_week content integer equals 5
# This is more straightforward: declaration and value are given at once,
# no need for a sub-variable name.
```
b. The General Lunch Allocation is $2 per workday, over the number of work weeks.
```catala
declaration scope LunchAllocation_B:
input number_of_work_weeks content integer
output value content money
scope LunchAllocation_B:
definition value equals $2 * (number_of_work_weeks * workdays_per_week / 7)
# No need for a subscope, `workdays_per_week` is accessed directly by name
```
## Example 2: toplevel functions
a. The base allocation is equal to 30% of the rent
```catala
declaration scope Allocation:
input rent content money
output value content money
state base
state final
scope Allocation:
definition value state base equals rent * 30%
```
### A. With the current syntax
b. The final allocation is rounded up to the next multiple of $100
```catala
scope Allocation:
definition value state final equals
round of (value / 100.0 + $0.49) * 100.0
# Here you should explain why that formula does what the text says,
# since that's far from obvious
# It's ok if it's just used once, but far from ideal if that specific
# rounding is used all over the law.
```
### B. Proposed new syntax for "toplevel functions"
b. The final allocation is rounded up to the next multiple of $100
```catala
declaration round_up_100
content money
depends on money_amount content money
equals
(money_amount / 100.0 + $0.49) * 100.0
# The explanation is still needed, but it doesn't clutter the current scope
# This definition could even be put in the Prelude
scope Allocation:
definition value state final equals round_up_100 of value
```
## Example 3: functions with multiple parameters
The amount to include in gross income is the excess of the fair market value of
the property over the amount paid.
```catala-metadata
declaration scope IncludeInGrossIncome:
input fair_market_value content money
input amount_paid content money
output amount_to_include content money
```
### A. With the current syntax
```catala
scope IncludeInGrossIncome:
definition amount_to_include equals
if fair_market_value > amount_paid then fair_market_value - amount_paid
else $0
# That's basically the definition of "excess of"
```
### A. With a two-argument function
```catala
declaration excess
content money
depends on x content money,
y content money
equals
if x > y then x - y
else $0
scope IncludeInGrossIncome:
definition amount_to_include equals excess of fair_market_value, amount_paid
```

12
flake.lock
View File

@ -2,11 +2,11 @@
"nodes": {
"flake-utils": {
"locked": {
"lastModified": 1667395993,
"narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=",
"lastModified": 1676283394,
"narHash": "sha256-XX2f9c3iySLCw54rJ/CZs+ZK6IQy7GXNY4nSOyu2QG4=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f",
"rev": "3db36a8b464d0c4532ba1c7dda728f4576d6d073",
"type": "github"
},
"original": {
@ -17,11 +17,11 @@
},
"nixpkgs": {
"locked": {
"lastModified": 1673631141,
"narHash": "sha256-AprpYQ5JvLS4wQG/ghm2UriZ9QZXvAwh1HlgA/6ZEVQ=",
"lastModified": 1677407201,
"narHash": "sha256-3blwdI9o1BAprkvlByHvtEm5HAIRn/XPjtcfiunpY7s=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "befc83905c965adfd33e5cae49acb0351f6e0404",
"rev": "7f5639fa3b68054ca0b062866dc62b22c3f11505",
"type": "github"
},
"original": {

12
flake.nix
View File

@ -1,7 +1,7 @@
{
inputs = {
flake-utils.url = github:numtide/flake-utils;
nixpkgs.url = github:NixOS/nixpkgs/nixos-unstable;
flake-utils.url = "github:numtide/flake-utils";
nixpkgs.url = "github:NixOS/nixpkgs/nixos-unstable";
};
outputs = {nixpkgs, flake-utils, ...}:
@ -19,14 +19,18 @@
};
defaultPackage = packages.catala;
devShell = pkgs.mkShell {
inputsFrom = [packages.catala];
inputsFrom = [ packages.catala ];
buildInputs = [
pkgs.inotify-tools
ocamlPackages.merlin
pkgs.ocamlformat
pkgs.ocamlformat_0_21_0
ocamlPackages.ocp-indent
ocamlPackages.utop
ocamlPackages.odoc
ocamlPackages.ocaml-lsp
pkgs.groff
pkgs.obelisk
pkgs.ninja
];
};
}

10340
french_law/js/french_law.js generated
View File

File diff suppressed because one or more lines are too long

15881
french_law/ocaml/law_source/aides_logement.ml generated
View File

File diff suppressed because it is too large Load Diff

769
french_law/ocaml/law_source/aides_logement_api_web.ml generated
View File

File diff suppressed because it is too large Load Diff

150
french_law/ocaml/law_source/allocations_familiales.ml generated
View File

@ -1212,7 +1212,7 @@ let prestations_familiales (prestations_familiales_in: PrestationsFamilialesIn.t
let conditions_hors_age_: Enfant.t -> bool = (log_variable_definition
["PrestationsFamiliales"; "conditions_hors_âge"] (unembeddable) (
try
(fun (param_: Enfant.t) ->
(fun (param0_: Enfant.t) ->
try
(handle_default
{filename = "examples/allocations_familiales/prologue.catala_fr";
@ -1239,7 +1239,7 @@ let prestations_familiales (prestations_familiales_in: PrestationsFamilialesIn.t
"Code de la sécurité sociale"]}
(o_and
(o_or
(match (param_.Enfant.obligation_scolaire)
(match (param0_.Enfant.obligation_scolaire)
with
| SituationObligationScolaire.Avant _ -> true
| SituationObligationScolaire.Pendant _ ->
@ -1247,7 +1247,7 @@ let prestations_familiales (prestations_familiales_in: PrestationsFamilialesIn.t
| SituationObligationScolaire.Apres _ ->
false)
(o_or
(match (param_.Enfant.obligation_scolaire)
(match (param0_.Enfant.obligation_scolaire)
with
| SituationObligationScolaire.Avant _ ->
false
@ -1255,7 +1255,7 @@ let prestations_familiales (prestations_familiales_in: PrestationsFamilialesIn.t
true
| SituationObligationScolaire.Apres _ ->
false)
(match (param_.Enfant.obligation_scolaire)
(match (param0_.Enfant.obligation_scolaire)
with
| SituationObligationScolaire.Avant _ ->
false
@ -1264,7 +1264,7 @@ let prestations_familiales (prestations_familiales_in: PrestationsFamilialesIn.t
| SituationObligationScolaire.Apres _ ->
true)))
(o_lte_mon_mon
(param_.Enfant.remuneration_mensuelle)
(param0_.Enfant.remuneration_mensuelle)
plafond_l512_3_2_)))) (fun (_: unit) -> true))|])
(fun (_: unit) -> (log_decision_taken
{filename = "examples/allocations_familiales/prologue.catala_fr";
@ -1288,7 +1288,7 @@ let prestations_familiales (prestations_familiales_in: PrestationsFamilialesIn.t
let droit_ouvert_: Enfant.t -> bool = (log_variable_definition
["PrestationsFamiliales"; "droit_ouvert"] (unembeddable) (
try
(fun (param_: Enfant.t) ->
(fun (param0_: Enfant.t) ->
try
(handle_default
{filename = "examples/allocations_familiales/prologue.catala_fr";
@ -1322,7 +1322,7 @@ let prestations_familiales (prestations_familiales_in: PrestationsFamilialesIn.t
"Livre VIII : Aides personnelles au logement";
"Partie législative";
"Code de la construction et de l'habitation"]}
(param_.Enfant.beneficie_titre_personnel_aide_personnelle_logement)))
(param0_.Enfant.beneficie_titre_personnel_aide_personnelle_logement)))
(fun (_: unit) -> false))|])
(fun (_: unit) -> true)
(fun (_: unit) ->
@ -1364,7 +1364,7 @@ let prestations_familiales (prestations_familiales_in: PrestationsFamilialesIn.t
"Code de la sécurité sociale"]}
(o_and
(match
(param_.Enfant.obligation_scolaire)
(param0_.Enfant.obligation_scolaire)
with
| SituationObligationScolaire.Avant _ ->
false
@ -1374,11 +1374,11 @@ let prestations_familiales (prestations_familiales_in: PrestationsFamilialesIn.t
true)
(o_and
(o_lte_mon_mon
(param_.Enfant.remuneration_mensuelle)
(param0_.Enfant.remuneration_mensuelle)
plafond_l512_3_2_)
(o_gt_dat_dat
(o_add_dat_dur
(param_.Enfant.date_de_naissance)
(param0_.Enfant.date_de_naissance)
age_l512_3_2_)
date_courante_)))))
(fun (_: unit) -> true))|])
@ -1394,7 +1394,7 @@ let prestations_familiales (prestations_familiales_in: PrestationsFamilialesIn.t
"Code de la sécurité sociale"]}
(o_or
(match
(param_.Enfant.obligation_scolaire)
(param0_.Enfant.obligation_scolaire)
with
| SituationObligationScolaire.Avant _ ->
true
@ -1403,7 +1403,7 @@ let prestations_familiales (prestations_familiales_in: PrestationsFamilialesIn.t
| SituationObligationScolaire.Apres _ ->
false)
(match
(param_.Enfant.obligation_scolaire)
(param0_.Enfant.obligation_scolaire)
with
| SituationObligationScolaire.Avant _ ->
false
@ -1449,7 +1449,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
let prise_en_compte_: Enfant.t -> PriseEnCompte.t = (log_variable_definition
["AllocationsFamiliales"; "prise_en_compte"] (unembeddable) (
try
(fun (param_: Enfant.t) ->
(fun (param0_: Enfant.t) ->
try
(handle_default
{filename = "examples/allocations_familiales/prologue.catala_fr";
@ -1474,7 +1474,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Livre 5 : Prestations familiales et prestations assimilées";
"Partie législative";
"Code de la sécurité sociale"]}
(match (param_.Enfant.prise_en_charge)
(match (param0_.Enfant.prise_en_charge)
with
| PriseEnCharge.GardeAlterneePartageAllocations _ ->
true
@ -1504,7 +1504,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Livre 5 : Prestations familiales et prestations assimilées";
"Partie législative";
"Code de la sécurité sociale"]}
(match (param_.Enfant.prise_en_charge)
(match (param0_.Enfant.prise_en_charge)
with
| PriseEnCharge.GardeAlterneePartageAllocations _ ->
false
@ -1551,7 +1551,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Partie législative";
"Code de la sécurité sociale"]}
(match
(param_.Enfant.prise_en_charge)
(param0_.Enfant.prise_en_charge)
with
| PriseEnCharge.GardeAlterneePartageAllocations _ ->
false
@ -1575,7 +1575,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Livre 5 : Prestations familiales et prestations assimilées";
"Partie législative";
"Code de la sécurité sociale"]}
(match (param_.Enfant.prise_en_charge)
(match (param0_.Enfant.prise_en_charge)
with
| PriseEnCharge.GardeAlterneePartageAllocations _ ->
false
@ -1598,7 +1598,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Livre 5 : Prestations familiales et prestations assimilées";
"Partie législative";
"Code de la sécurité sociale"]}
(match (param_.Enfant.prise_en_charge)
(match (param0_.Enfant.prise_en_charge)
with
| PriseEnCharge.GardeAlterneePartageAllocations _ ->
false
@ -1626,7 +1626,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
let versement_: Enfant.t -> VersementAllocations.t = (log_variable_definition
["AllocationsFamiliales"; "versement"] (unembeddable) (
try
(fun (param_: Enfant.t) ->
(fun (param0_: Enfant.t) ->
try
(handle_default
{filename = "examples/allocations_familiales/prologue.catala_fr";
@ -1651,7 +1651,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Livre 5 : Prestations familiales et prestations assimilées";
"Partie législative";
"Code de la sécurité sociale"]}
(match (param_.Enfant.prise_en_charge)
(match (param0_.Enfant.prise_en_charge)
with
| PriseEnCharge.GardeAlterneePartageAllocations _ ->
false
@ -1711,7 +1711,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Partie législative";
"Code de la sécurité sociale"]}
(match
(param_.Enfant.prise_en_charge)
(param0_.Enfant.prise_en_charge)
with
| PriseEnCharge.GardeAlterneePartageAllocations _ ->
false
@ -1737,7 +1737,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Partie législative";
"Code de la sécurité sociale"]}
(match
(param_.Enfant.prise_en_charge)
(param0_.Enfant.prise_en_charge)
with
| PriseEnCharge.GardeAlterneePartageAllocations _ ->
true
@ -1761,7 +1761,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Livre 5 : Prestations familiales et prestations assimilées";
"Partie législative";
"Code de la sécurité sociale"]}
(match (param_.Enfant.prise_en_charge)
(match (param0_.Enfant.prise_en_charge)
with
| PriseEnCharge.GardeAlterneePartageAllocations _ ->
false
@ -1785,7 +1785,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Livre 5 : Prestations familiales et prestations assimilées";
"Partie législative";
"Code de la sécurité sociale"]}
(match (param_.Enfant.prise_en_charge)
(match (param0_.Enfant.prise_en_charge)
with
| PriseEnCharge.GardeAlterneePartageAllocations _ ->
false
@ -2002,7 +2002,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
["AllocationsFamiliales"; "âge_minimum_alinéa_1_l521_3"] (unembeddable)
(
try
(fun (param_: Enfant.t) ->
(fun (param0_: Enfant.t) ->
try
(handle_default
{filename = "examples/allocations_familiales/prologue.catala_fr";
@ -2028,7 +2028,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
"Partie réglementaire - Décrets en Conseil d'Etat";
"Code de la sécurité sociale"]}
(o_lte_dat_dat
(o_add_dat_dur (param_.Enfant.date_de_naissance)
(o_add_dat_dur (param0_.Enfant.date_de_naissance)
(duration_of_numbers (11) (0) (0)))
(date_of_numbers (2008) (4) (30)))))
(fun (_: unit) ->
@ -2085,7 +2085,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
["PrestationsFamiliales"; "droit_ouvert"]
prestations_familiales_dot_droit_ouvert_)
((log_variable_definition
["PrestationsFamiliales"; "droit_ouvert"; "input"]
["PrestationsFamiliales"; "droit_ouvert"; "input0"]
(embed_enfant) enfant_))))))) enfants_a_charge_))
with
EmptyError -> (raise (NoValueProvided
@ -2096,7 +2096,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
let est_enfant_le_plus_age_: Enfant.t -> bool = (log_variable_definition
["AllocationsFamiliales"; "est_enfant_le_plus_âgé"] (unembeddable) (
try
(fun (param_: Enfant.t) ->
(fun (param0_: Enfant.t) ->
try
(handle_default
{filename = "examples/allocations_familiales/prologue.catala_fr";
@ -2110,7 +2110,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
end_line=34; end_column=36;
law_headings=["Règles diverses"; "Épilogue"]} true))
(fun (_: unit) ->
o_eq enfant_le_plus_age_dot_le_plus_age_ param_))
o_eq enfant_le_plus_age_dot_le_plus_age_ param0_))
with
EmptyError -> (raise (NoValueProvided
{filename = "examples/allocations_familiales/prologue.catala_fr";
@ -2468,7 +2468,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
let droit_ouvert_forfaitaire_: Enfant.t -> bool = (log_variable_definition
["AllocationsFamiliales"; "droit_ouvert_forfaitaire"] (unembeddable) (
try
(fun (param_: Enfant.t) ->
(fun (param0_: Enfant.t) ->
try
(handle_default
{filename = "examples/allocations_familiales/prologue.catala_fr";
@ -2524,12 +2524,12 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
(o_lt_dur_dur
(o_sub_dat_dat
(o_add_dat_dur
(param_.Enfant.date_de_naissance)
(param0_.Enfant.date_de_naissance)
prestations_familiales_dot_age_l512_3_2_)
date_courante_)
(duration_of_numbers (0) (0) (365)))
(o_and
(param_.Enfant.a_deja_ouvert_droit_aux_allocations_familiales)
(param0_.Enfant.a_deja_ouvert_droit_aux_allocations_familiales)
((log_end_call
["PrestationsFamiliales";
"conditions_hors_âge"]
@ -2542,8 +2542,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
prestations_familiales_dot_conditions_hors_age_)
((log_variable_definition
["PrestationsFamiliales";
"conditions_hors_âge"; "input"]
(embed_enfant) param_))))))))))))
"conditions_hors_âge"; "input0"]
(embed_enfant) param0_))))))))))))
(fun (_: unit) -> true))|])
(fun (_: unit) -> (log_decision_taken
{filename = "examples/allocations_familiales/prologue.catala_fr";
@ -3006,7 +3006,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
(embed_prise_en_compte) ((log_begin_call
["AllocationsFamiliales"; "prise_en_compte"]
prise_en_compte_) ((log_variable_definition
["AllocationsFamiliales"; "prise_en_compte"; "input"]
["AllocationsFamiliales"; "prise_en_compte"; "input0"]
(embed_enfant) enfant_)))))))
with
| PriseEnCompte.Complete _ -> (decimal_of_string "1.")
@ -3586,7 +3586,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
let droit_ouvert_majoration_: Enfant.t -> bool = (log_variable_definition
["AllocationsFamiliales"; "droit_ouvert_majoration"] (unembeddable) (
try
(fun (param_: Enfant.t) ->
(fun (param0_: Enfant.t) ->
try
(handle_default
{filename = "examples/allocations_familiales/prologue.catala_fr";
@ -3625,7 +3625,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
nombre_enfants_alinea_2_l521_3_)
(o_lte_dat_dat
(o_add_dat_dur
(param_.Enfant.date_de_naissance)
(param0_.Enfant.date_de_naissance)
((log_end_call
["AllocationsFamiliales";
"âge_minimum_alinéa_1_l521_3"]
@ -3640,8 +3640,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
((log_variable_definition
["AllocationsFamiliales";
"âge_minimum_alinéa_1_l521_3";
"input"] (embed_enfant)
param_)))))))) date_courante_))))
"input0"] (embed_enfant)
param0_)))))))) date_courante_))))
(fun (_: unit) -> true))|])
(fun (_: unit) -> (log_decision_taken
{filename = "examples/allocations_familiales/securite_sociale_L.catala_fr";
@ -3666,11 +3666,11 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
est_enfant_le_plus_age_)
((log_variable_definition
["AllocationsFamiliales";
"est_enfant_le_plus_âgé"; "input"]
(embed_enfant) param_))))))))
"est_enfant_le_plus_âgé"; "input0"]
(embed_enfant) param0_))))))))
(o_lte_dat_dat
(o_add_dat_dur
(param_.Enfant.date_de_naissance)
(param0_.Enfant.date_de_naissance)
((log_end_call
["AllocationsFamiliales";
"âge_minimum_alinéa_1_l521_3"]
@ -3684,8 +3684,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
age_minimum_alinea_1_l521_3_)
((log_variable_definition
["AllocationsFamiliales";
"âge_minimum_alinéa_1_l521_3"; "input"]
(embed_enfant) param_))))))))
"âge_minimum_alinéa_1_l521_3";
"input0"] (embed_enfant) param0_))))))))
date_courante_)))) (fun (_: unit) -> true))|])
(fun (_: unit) -> (log_decision_taken
{filename = "examples/allocations_familiales/prologue.catala_fr";
@ -3709,7 +3709,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
let complement_degressif_: money -> money = (log_variable_definition
["AllocationsFamiliales"; "complément_dégressif"] (unembeddable) (
try
(fun (param_: money) ->
(fun (param0_: money) ->
try
(handle_default
{filename = "examples/allocations_familiales/prologue.catala_fr";
@ -3746,13 +3746,13 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
plafond__i_d521_3_)
(o_lte_mon_mon ressources_menage_
(o_add_mon_mon plafond__i_d521_3_
(o_mult_mon_rat param_
(o_mult_mon_rat param0_
(decimal_of_string "12.")))))))
(fun (_: unit) ->
o_mult_mon_rat
(o_sub_mon_mon
(o_add_mon_mon plafond__i_d521_3_
(o_mult_mon_rat param_
(o_mult_mon_rat param0_
(decimal_of_string "12.")))
ressources_menage_)
(o_div_rat_rat (decimal_of_string "1.")
@ -3780,13 +3780,13 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
plafond__i_i_d521_3_)
(o_lte_mon_mon ressources_menage_
(o_add_mon_mon plafond__i_i_d521_3_
(o_mult_mon_rat param_
(o_mult_mon_rat param0_
(decimal_of_string "12.")))))))
(fun (_: unit) ->
o_mult_mon_rat
(o_sub_mon_mon
(o_add_mon_mon plafond__i_i_d521_3_
(o_mult_mon_rat param_
(o_mult_mon_rat param0_
(decimal_of_string "12.")))
ressources_menage_)
(o_div_rat_rat (decimal_of_string "1.")
@ -4518,7 +4518,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
["AllocationsFamiliales"; "montant_initial_métropole_majoration"]
(unembeddable) (
try
(fun (param_: Enfant.t) ->
(fun (param0_: Enfant.t) ->
try
(handle_default
{filename = "examples/allocations_familiales/prologue.catala_fr";
@ -4557,8 +4557,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
droit_ouvert_majoration_)
((log_variable_definition
["AllocationsFamiliales";
"droit_ouvert_majoration"; "input"]
(embed_enfant) param_))))))))))
"droit_ouvert_majoration"; "input0"]
(embed_enfant) param0_))))))))))
(fun (_: unit) ->
o_mult_mon_rat bmaf_dot_montant_
(decimal_of_string "0.16")));
@ -4597,8 +4597,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
droit_ouvert_majoration_)
((log_variable_definition
["AllocationsFamiliales";
"droit_ouvert_majoration"; "input"]
(embed_enfant) param_))))))))))
"droit_ouvert_majoration"; "input0"]
(embed_enfant) param0_))))))))))
(fun (_: unit) ->
o_mult_mon_rat bmaf_dot_montant_
(decimal_of_string "0.08")));
@ -4634,8 +4634,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
droit_ouvert_majoration_)
((log_variable_definition
["AllocationsFamiliales";
"droit_ouvert_majoration"; "input"]
(embed_enfant) param_))))))))))
"droit_ouvert_majoration"; "input0"]
(embed_enfant) param0_))))))))))
(fun (_: unit) ->
o_mult_mon_rat bmaf_dot_montant_
(decimal_of_string "0.04")));
@ -4664,8 +4664,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
droit_ouvert_majoration_)
((log_variable_definition
["AllocationsFamiliales";
"droit_ouvert_majoration"; "input"]
(embed_enfant) param_))))))))))
"droit_ouvert_majoration"; "input0"]
(embed_enfant) param0_))))))))))
(fun (_: unit) -> money_of_cents_string "0"))|])
(fun (_: unit) -> false) (fun (_: unit) -> raise EmptyError))
with
@ -4714,7 +4714,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
droit_ouvert_forfaitaire_)
((log_variable_definition
["AllocationsFamiliales";
"droit_ouvert_forfaitaire"; "input"]
"droit_ouvert_forfaitaire"; "input0"]
(embed_enfant) enfant_))))))) enfants_a_charge_)))))
with
EmptyError -> (raise (NoValueProvided
@ -4809,7 +4809,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
let montant_initial_majoration_: Enfant.t -> money = (log_variable_definition
["AllocationsFamiliales"; "montant_initial_majoration"] (unembeddable) (
try
(fun (param_: Enfant.t) ->
(fun (param0_: Enfant.t) ->
try
(handle_default
{filename = "examples/allocations_familiales/prologue.catala_fr";
@ -4853,8 +4853,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
droit_ouvert_majoration_)
((log_variable_definition
["AllocationsFamiliales";
"droit_ouvert_majoration"; "input"]
(embed_enfant) param_)))))))
"droit_ouvert_majoration"; "input0"]
(embed_enfant) param0_)))))))
(o_and
prestations_familiales_dot_regime_outre_mer_l751_1_
(o_and
@ -4865,12 +4865,12 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
(o_and
(o_lte_dat_dat
(o_add_dat_dur
(param_.Enfant.date_de_naissance)
(param0_.Enfant.date_de_naissance)
(duration_of_numbers (11) (0) (0)))
date_courante_)
(o_gt_dat_dat
(o_add_dat_dur
(param_.Enfant.date_de_naissance)
(param0_.Enfant.date_de_naissance)
(duration_of_numbers (16) (0) (0)))
date_courante_)))))))
(fun (_: unit) ->
@ -4906,8 +4906,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
droit_ouvert_majoration_)
((log_variable_definition
["AllocationsFamiliales";
"droit_ouvert_majoration"; "input"]
(embed_enfant) param_)))))))
"droit_ouvert_majoration"; "input0"]
(embed_enfant) param0_)))))))
(o_and
prestations_familiales_dot_regime_outre_mer_l751_1_
(o_and
@ -4917,7 +4917,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
(integer_of_string "1"))
(o_lte_dat_dat
(o_add_dat_dur
(param_.Enfant.date_de_naissance)
(param0_.Enfant.date_de_naissance)
(duration_of_numbers (16) (0) (0)))
date_courante_))))))
(fun (_: unit) ->
@ -4947,8 +4947,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
montant_initial_metropole_majoration_)
((log_variable_definition
["AllocationsFamiliales";
"montant_initial_métropole_majoration"; "input"]
(embed_enfant) param_))))))))
"montant_initial_métropole_majoration"; "input0"]
(embed_enfant) param0_))))))))
with
EmptyError -> (raise (NoValueProvided
{filename = "examples/allocations_familiales/prologue.catala_fr";
@ -5096,7 +5096,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
["AllocationsFamiliales"; "montant_avec_garde_alternée_majoration"]
(unembeddable) (
try
(fun (param_: Enfant.t) ->
(fun (param0_: Enfant.t) ->
try
(handle_default
{filename = "examples/allocations_familiales/prologue.catala_fr";
@ -5123,7 +5123,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
["AllocationsFamiliales"; "montant_initial_majoration"]
montant_initial_majoration_) ((log_variable_definition
["AllocationsFamiliales"; "montant_initial_majoration";
"input"] (embed_enfant) param_)))))))
"input0"] (embed_enfant) param0_)))))))
(match ((log_end_call
["AllocationsFamiliales"; "prise_en_compte"]
((log_variable_definition
@ -5131,8 +5131,8 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
(embed_prise_en_compte) ((log_begin_call
["AllocationsFamiliales"; "prise_en_compte"]
prise_en_compte_) ((log_variable_definition
["AllocationsFamiliales"; "prise_en_compte"; "input"]
(embed_enfant) param_)))))))
["AllocationsFamiliales"; "prise_en_compte"; "input0"]
(embed_enfant) param0_)))))))
with
| PriseEnCompte.Complete _ -> (decimal_of_string "1.")
| PriseEnCompte.Partagee _ -> (decimal_of_string "0.5")
@ -5200,7 +5200,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
montant_avec_garde_alternee_majoration_)
((log_variable_definition
["AllocationsFamiliales";
"montant_avec_garde_alternée_majoration"; "input"]
"montant_avec_garde_alternée_majoration"; "input0"]
(embed_enfant) enfant_))))))) enfants_a_charge_)) else
(money_of_cents_string "0")))
with
@ -5262,7 +5262,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
(embed_money) ((log_begin_call
["AllocationsFamiliales"; "complément_dégressif"]
complement_degressif_) ((log_variable_definition
["AllocationsFamiliales"; "complément_dégressif"; "input"]
["AllocationsFamiliales"; "complément_dégressif"; "input0"]
(embed_money)
montant_base_complement_pour_base_et_majoration_))))))) else
(money_of_cents_string "0")))

15
french_law/ocaml/law_source/allocations_familiales_api_web.ml generated
View File

@ -532,9 +532,10 @@ class type enfant_le_plus_age =
class type prestations_familiales =
object
method droitOuvert: (enfant Js.t, bool Js.t) Js.meth_callback Js.meth
method droitOuvert:
(unit, enfant Js.t -> bool Js.t) Js.meth_callback Js.meth
method conditionsHorsAge:
(enfant Js.t, bool Js.t) Js.meth_callback Js.meth
(unit, enfant Js.t -> bool Js.t) Js.meth_callback Js.meth
method ageL51232: Runtime_jsoo.Runtime.duration Js.t Js.readonly_prop
method regimeOutreMerL7511: bool Js.t Js.readonly_prop
end
@ -543,12 +544,14 @@ class type prestations_familiales =
object%js
method droitOuvert = Js.wrap_meth_callback
(
fun input ->
Js.bool (prestations_familiales.droit_ouvert (enfant_of_jsoo input)))
fun _ (function_input0: enfant Js.t) ->
Js.bool (prestations_familiales.droit_ouvert (enfant_of_jsoo
function_input0)))
method conditionsHorsAge = Js.wrap_meth_callback
(
fun input ->
Js.bool (prestations_familiales.conditions_hors_age (enfant_of_jsoo input)))
fun _ (function_input0: enfant Js.t) ->
Js.bool (prestations_familiales.conditions_hors_age (enfant_of_jsoo
function_input0)))
val ageL51232 = duration_to_jsoo prestations_familiales.age_l512_3_2
val regimeOutreMerL7511 =
Js.bool prestations_familiales.regime_outre_mer_l751_1

12
runtimes/python/catala/src/catala/runtime.py
View File

@ -151,7 +151,7 @@ class Money:
def __truediv__(self, other: 'Money') -> Decimal:
if isinstance(other, Money):
return Decimal(mpq(self.value.value / other.value.value))
return self.value / other.value
elif isinstance(other, Decimal):
return self * (1. / other.value)
else:
@ -200,7 +200,7 @@ class Date:
def __sub__(self, other: object) -> object:
if isinstance(other, Date):
return Duration(dateutil.relativedelta.relativedelta(self.value, other.value))
return Duration(dateutil.relativedelta.relativedelta(days=(self.value - other.value).days))
elif isinstance(other, Duration):
return Date(self.value - other.value)
else:
@ -368,22 +368,22 @@ class EmptyError(Exception):
class AssertionFailed(Exception):
def __init__(self, source_position: SourcePosition) -> None:
self.source_position = SourcePosition
self.source_position = source_position
class ConflictError(Exception):
def __init__(self, source_position: SourcePosition) -> None:
self.source_position = SourcePosition
self.source_position = source_position
class NoValueProvided(Exception):
def __init__(self, source_position: SourcePosition) -> None:
self.source_position = SourcePosition
self.source_position = source_position
class AssertionFailure(Exception):
def __init__(self, source_position: SourcePosition) -> None:
self.source_position = SourcePosition
self.source_position = source_position
# ============================

8
tests/test_func/good/context_func.catala_en
View File

@ -19,7 +19,7 @@ scope B:
$ catala Scopelang -s B
let scope B (b: bool|input) =
let a.f : integer → integer =
λ (param: integer) → ⟨b && param >! 0 ⊢ param -! 1⟩;
λ (param0: integer) → ⟨b && param0 >! 0 ⊢ param0 -! 1⟩;
call A[a]
```
@ -29,8 +29,8 @@ let A =
λ (A_in: A_in {"f_in": integer → integer}) →
let f : integer → integer = A_in."f_in" in
let f1 : integer → integer =
λ (param: integer) → error_empty
⟨f param | true ⊢ ⟨true ⊢ param +! 1⟩⟩ in
λ (param0: integer) → error_empty
⟨f param0 | true ⊢ ⟨true ⊢ param0 +! 1⟩⟩ in
A { }
```
@ -40,7 +40,7 @@ let B =
λ (B_in: B_in {"b_in": bool}) →
let b : bool = B_in."b_in" in
let a.f : integer → integer =
λ (param: integer) → ⟨b && param >! 0 ⊢ param -! 1⟩ in
λ (param0: integer) → ⟨b && param0 >! 0 ⊢ param0 -! 1⟩ in
let result : A {} = A (A_in { "f_in"= a.f }) in
B { }
```

24
tests/test_name_resolution/bad/toplevel_defs.catala_en Normal file
View File

@ -0,0 +1,24 @@
## Scope calls are not allowed outside of scopes
```catala
declaration scope S1:
output a content decimal
scope S1:
definition a equals 44.2
declaration glob5 content decimal
equals (output of S1).a
```
```catala-test-inline
$ catala typecheck
[ERROR] Scope calls are not allowed outside of a scope
┌─⯈ tests/test_name_resolution/bad/toplevel_defs.catala_en:11.10-22:
└──┐
11 │ equals (output of S1).a
│ ‾‾‾‾‾‾‾‾‾‾‾‾
└─ Scope calls are not allowed outside of scopes
#return code 255#
```

474
tests/test_name_resolution/good/toplevel_defs.catala_en Normal file
View File

@ -0,0 +1,474 @@
## Test basic toplevel values defs
```catala
declaration glob1 content decimal equals 44.12
declaration scope S:
output a content decimal
output b content A
declaration structure A:
data y content boolean
data z content decimal
declaration glob2 content A equals
A { --y: glob1 >= 30. --z: 123. * 17. }
scope S:
definition a equals glob1 * glob1
definition b equals glob2
```
```catala-test-inline
$ catala Interpret -s S
[RESULT] Computation successful! Results:
[RESULT] a = 1946.5744
[RESULT] b = A { "y"= true; "z"= 2091. }
```
## Test toplevel function defs
```catala
declaration glob3 content decimal
depends on x content money
equals decimal of x + 10.
declaration scope S2:
output a content decimal
scope S2:
definition a equals glob3 of $44 + 100.
```
```catala-test-inline
$ catala Interpret -s S2
[RESULT] Computation successful! Results:
[RESULT] a = 154.
```
## Test function def with two args
```catala
declaration glob4 content decimal
depends on x content money, y content decimal
equals decimal of x * y + 10.
declaration scope S3:
output a content decimal
scope S3:
definition a equals 50. + glob4 of $44, 55.
```
```catala-test-inline
$ catala Interpret -s S3
[RESULT] Computation successful! Results:
[RESULT] a = 2480.
```
## Test inline defs in toplevel defs
(can't define inline functions yet)
```catala
declaration glob5 content decimal equals
let x equals decimal of 2 * 3. in
let y equals 1000. in
x * y
declaration scope S4:
output a content decimal
scope S4:
definition a equals glob5 + 1.
```
```catala-test-inline
$ catala Interpret -s S4
[RESULT] Computation successful! Results:
[RESULT] a = 6001.
```
```catala-test-inline
$ catala scalc
let glob1_2 = 44.12
let glob3_3 (x_3: money) = return to_rat_mon x_3 +. 10.
let glob4_4 (x_4: money) (y_5: decimal) = return to_rat_mon x_4 *. y_5 +. 10.
let glob5_aux_5 =
decl glob5_7 : any;
let glob5_7 (x_8 : decimal) =
decl y_9 : decimal;
y_9 = 1000.;
return x_8 *. y_9;
return glob5_7 to_rat_int 2 *. 3.
let glob5_6 = glob5_aux_5 ()
let glob2_10 = A {"y": glob1_2 >=. 30., "z": 123. *. 17.}
let S2_6 (S2_in_11: S2_in {}) =
decl temp_a_13 : any;
try:
decl temp_a_16 : any;
let temp_a_16 (__17 : unit) =
return glob3_3 $44.00 +. 100.;
decl temp_a_14 : any;
let temp_a_14 (__15 : unit) =
return true;
temp_a_13 = handle_default_1 [] temp_a_14 temp_a_16
with EmptyError:
temp_a_13 = dead_value_1;
raise NoValueProvided;
decl a_12 : decimal;
a_12 = temp_a_13;
return S2 {"a": a_12}
let S3_7 (S3_in_18: S3_in {}) =
decl temp_a_20 : any;
try:
decl temp_a_23 : any;
let temp_a_23 (__24 : unit) =
return 50. +. glob4_4 $44.00 55.;
decl temp_a_21 : any;
let temp_a_21 (__22 : unit) =
return true;
temp_a_20 = handle_default_1 [] temp_a_21 temp_a_23
with EmptyError:
temp_a_20 = dead_value_1;
raise NoValueProvided;
decl a_19 : decimal;
a_19 = temp_a_20;
return S3 {"a": a_19}
let S4_8 (S4_in_25: S4_in {}) =
decl temp_a_27 : any;
try:
decl temp_a_30 : any;
let temp_a_30 (__31 : unit) =
return glob5_6 +. 1.;
decl temp_a_28 : any;
let temp_a_28 (__29 : unit) =
return true;
temp_a_27 = handle_default_1 [] temp_a_28 temp_a_30
with EmptyError:
temp_a_27 = dead_value_1;
raise NoValueProvided;
decl a_26 : decimal;
a_26 = temp_a_27;
return S4 {"a": a_26}
let S_9 (S_in_32: S_in {}) =
decl temp_a_40 : any;
try:
decl temp_a_43 : any;
let temp_a_43 (__44 : unit) =
return glob1_2 *. glob1_2;
decl temp_a_41 : any;
let temp_a_41 (__42 : unit) =
return true;
temp_a_40 = handle_default_1 [] temp_a_41 temp_a_43
with EmptyError:
temp_a_40 = dead_value_1;
raise NoValueProvided;
decl a_33 : decimal;
a_33 = temp_a_40;
decl temp_b_35 : any;
try:
decl temp_b_38 : any;
let temp_b_38 (__39 : unit) =
return glob2_10;
decl temp_b_36 : any;
let temp_b_36 (__37 : unit) =
return true;
temp_b_35 = handle_default_1 [] temp_b_36 temp_b_38
with EmptyError:
temp_b_35 = dead_value_1;
raise NoValueProvided;
decl b_34 : A {"y": bool; "z": decimal};
b_34 = temp_b_35;
return S {"a": a_33, "b": b_34}
```
```catala-test-inline
$ catala python
# This file has been generated by the Catala compiler, do not edit!
from catala.runtime import *
from typing import Any, List, Callable, Tuple
from enum import Enum
class A:
def __init__(self, y: bool, z: Decimal) -> None:
self.y = y
self.z = z
def __eq__(self, other: object) -> bool:
if isinstance(other, A):
return (self.y == other.y and self.z == other.z)
else:
return False
def __ne__(self, other: object) -> bool:
return not (self == other)
def __str__(self) -> str:
return "A(y={},z={})".format(self.y, self.z)
class S2:
def __init__(self, a: Decimal) -> None:
self.a = a
def __eq__(self, other: object) -> bool:
if isinstance(other, S2):
return (self.a == other.a)
else:
return False
def __ne__(self, other: object) -> bool:
return not (self == other)
def __str__(self) -> str:
return "S2(a={})".format(self.a)
class S3:
def __init__(self, a: Decimal) -> None:
self.a = a
def __eq__(self, other: object) -> bool:
if isinstance(other, S3):
return (self.a == other.a)
else:
return False
def __ne__(self, other: object) -> bool:
return not (self == other)
def __str__(self) -> str:
return "S3(a={})".format(self.a)
class S4:
def __init__(self, a: Decimal) -> None:
self.a = a
def __eq__(self, other: object) -> bool:
if isinstance(other, S4):
return (self.a == other.a)
else:
return False
def __ne__(self, other: object) -> bool:
return not (self == other)
def __str__(self) -> str:
return "S4(a={})".format(self.a)
class S:
def __init__(self, a: Decimal, b: A) -> None:
self.a = a
self.b = b
def __eq__(self, other: object) -> bool:
if isinstance(other, S):
return (self.a == other.a and self.b == other.b)
else:
return False
def __ne__(self, other: object) -> bool:
return not (self == other)
def __str__(self) -> str:
return "S(a={},b={})".format(self.a, self.b)
class SIn:
def __init__(self, ) -> None:
pass
def __eq__(self, other: object) -> bool:
if isinstance(other, SIn):
return (True)
else:
return False
def __ne__(self, other: object) -> bool:
return not (self == other)
def __str__(self) -> str:
return "SIn()".format()
class S2In:
def __init__(self, ) -> None:
pass
def __eq__(self, other: object) -> bool:
if isinstance(other, S2In):
return (True)
else:
return False
def __ne__(self, other: object) -> bool:
return not (self == other)
def __str__(self) -> str:
return "S2In()".format()
class S3In:
def __init__(self, ) -> None:
pass
def __eq__(self, other: object) -> bool:
if isinstance(other, S3In):
return (True)
else:
return False
def __ne__(self, other: object) -> bool:
return not (self == other)
def __str__(self) -> str:
return "S3In()".format()
class S4In:
def __init__(self, ) -> None:
pass
def __eq__(self, other: object) -> bool:
if isinstance(other, S4In):
return (True)
else:
return False
def __ne__(self, other: object) -> bool:
return not (self == other)
def __str__(self) -> str:
return "S4In()".format()
glob1 = (decimal_of_string("44.12"))
def glob3(x:Money):
return (decimal_of_money(x) + decimal_of_string("10."))
def glob4(x_1:Money, y:Decimal):
return ((decimal_of_money(x_1) * y) + decimal_of_string("10."))
def glob5_aux():
def glob5(x_2:Decimal):
y_1 = decimal_of_string("1000.")
return (x_2 * y_1)
return glob5((decimal_of_integer(integer_of_string("2")) *
decimal_of_string("3.")))
glob5_1 = (glob5_aux())
glob2 = (
A(y = (glob1 >=
decimal_of_string("30.")),
z = (decimal_of_string("123.") *
decimal_of_string("17.")))
)
def s2(s2_in:S2In):
try:
def temp_a(_:Unit):
return (glob3(money_of_cents_string("4400")) +
decimal_of_string("100."))
def temp_a_1(_:Unit):
return True
temp_a_2 = handle_default(SourcePosition(filename="tests/test_name_resolution/good/toplevel_defs.catala_en",
start_line=37, start_column=10,
end_line=37, end_column=11,
law_headings=["Test toplevel function defs"]), [],
temp_a_1, temp_a)
except EmptyError:
temp_a_2 = dead_value
raise NoValueProvided(SourcePosition(filename="tests/test_name_resolution/good/toplevel_defs.catala_en",
start_line=37, start_column=10,
end_line=37, end_column=11,
law_headings=["Test toplevel function defs"]))
a = temp_a_2
return S2(a = a)
def s3(s3_in:S3In):
try:
def temp_a_3(_:Unit):
return (decimal_of_string("50.") +
glob4(money_of_cents_string("4400"),
decimal_of_string("55.")))
def temp_a_4(_:Unit):
return True
temp_a_5 = handle_default(SourcePosition(filename="tests/test_name_resolution/good/toplevel_defs.catala_en",
start_line=57, start_column=10,
end_line=57, end_column=11,
law_headings=["Test function def with two args"]), [],
temp_a_4, temp_a_3)
except EmptyError:
temp_a_5 = dead_value
raise NoValueProvided(SourcePosition(filename="tests/test_name_resolution/good/toplevel_defs.catala_en",
start_line=57, start_column=10,
end_line=57, end_column=11,
law_headings=["Test function def with two args"]))
a_1 = temp_a_5
return S3(a = a_1)
def s4(s4_in:S4In):
try:
def temp_a_6(_:Unit):
return (glob5_1 + decimal_of_string("1."))
def temp_a_7(_:Unit):
return True
temp_a_8 = handle_default(SourcePosition(filename="tests/test_name_resolution/good/toplevel_defs.catala_en",
start_line=80, start_column=10,
end_line=80, end_column=11,
law_headings=["Test inline defs in toplevel defs"]), [],
temp_a_7, temp_a_6)
except EmptyError:
temp_a_8 = dead_value
raise NoValueProvided(SourcePosition(filename="tests/test_name_resolution/good/toplevel_defs.catala_en",
start_line=80, start_column=10,
end_line=80, end_column=11,
law_headings=["Test inline defs in toplevel defs"]))
a_2 = temp_a_8
return S4(a = a_2)
def s(s_in:SIn):
try:
def temp_a_9(_:Unit):
return (glob1 * glob1)
def temp_a_10(_:Unit):
return True
temp_a_11 = handle_default(SourcePosition(filename="tests/test_name_resolution/good/toplevel_defs.catala_en",
start_line=7, start_column=10,
end_line=7, end_column=11,
law_headings=["Test basic toplevel values defs"]), [],
temp_a_10, temp_a_9)
except EmptyError:
temp_a_11 = dead_value
raise NoValueProvided(SourcePosition(filename="tests/test_name_resolution/good/toplevel_defs.catala_en",
start_line=7, start_column=10,
end_line=7, end_column=11,
law_headings=["Test basic toplevel values defs"]))
a_3 = temp_a_11
try:
def temp_b(_:Unit):
return glob2
def temp_b_1(_:Unit):
return True
temp_b_2 = handle_default(SourcePosition(filename="tests/test_name_resolution/good/toplevel_defs.catala_en",
start_line=8, start_column=10,
end_line=8, end_column=11,
law_headings=["Test basic toplevel values defs"]), [],
temp_b_1, temp_b)
except EmptyError:
temp_b_2 = dead_value
raise NoValueProvided(SourcePosition(filename="tests/test_name_resolution/good/toplevel_defs.catala_en",
start_line=8, start_column=10,
end_line=8, end_column=11,
law_headings=["Test basic toplevel values defs"]))
b = temp_b_2
return S(a = a_3, b = b)
```

17
tests/test_name_resolution/good/toplevel_defs_simple.catala_en Normal file
View File

@ -0,0 +1,17 @@
## Test basic toplevel values defs
```catala
declaration glob1 content decimal equals 44.12
declaration scope S:
output a content boolean
scope S:
definition a equals glob1 >= 30.
```
```catala-test-inline
$ catala Interpret -s S
[RESULT] Computation successful! Results:
[RESULT] a = true
```

3
tests/test_scope/good/nothing.catala_en
View File

@ -7,11 +7,12 @@ declaration scope Foo2:
```catala-test-inline
$ catala Scalc -s Foo2 -O -t
let Foo2 (Foo2_in_2 : Foo2_in {}) =
let Foo2_3 (Foo2_in_2: Foo2_in {}) =
decl temp_bar_4 : any;
temp_bar_4 = dead_value_1;
raise NoValueProvided;
decl bar_3 : integer;
bar_3 = temp_bar_4;
return Foo2 {"bar": bar_3}
```

22
tests/test_scope/good/scope_call3.catala_en
View File

@ -26,7 +26,7 @@ $ catala Interpret -t -s HousingComputation
│ ‾‾‾‾‾‾
[LOG] → HousingComputation.f
[LOG] ≔ HousingComputation.f.input: 1
[LOG] ≔ HousingComputation.f.input0: 1
[LOG] ☛ Definition applied:
┌─⯈ tests/test_scope/good/scope_call3.catala_en:7.13-14:
└─┐
@ -43,10 +43,10 @@ $ catala Interpret -t -s HousingComputation
7 │ definition f of x equals (output of RentComputation).f of x
│ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾
[LOG] ≔ RentComputation.direct.output: RentComputation { "f"= λ (param: integer) → RentComputation { "f"= λ (param1: integer) → error_empty ⟨true ⊢ λ (param2: integer) → error_empty ⟨true ⊢ param2 +! 1⟩ param1 +! 1⟩ }."f" param }
[LOG] ≔ RentComputation.direct.output: RentComputation { "f"= λ (param0: integer) → RentComputation { "f"= λ (param01: integer) → error_empty ⟨true ⊢ λ (param02: integer) → error_empty ⟨true ⊢ param02 +! 1⟩ param01 +! 1⟩ }."f" param0 }
[LOG] ← RentComputation.direct
[LOG] → RentComputation.f
[LOG] ≔ RentComputation.f.input: 1
[LOG] ≔ RentComputation.f.input0: 1
[LOG] ☛ Definition applied:
┌─⯈ tests/test_scope/good/scope_call3.catala_en:16.13-14:
└──┐
@ -54,7 +54,7 @@ $ catala Interpret -t -s HousingComputation
│ ‾
[LOG] → RentComputation.g
[LOG] ≔ RentComputation.g.input: 2
[LOG] ≔ RentComputation.g.input0: 2
[LOG] ☛ Definition applied:
┌─⯈ tests/test_scope/good/scope_call3.catala_en:15.13-14:
└──┐
@ -70,20 +70,20 @@ $ catala Interpret -t -s HousingComputation
[LOG] ≔ HousingComputation.result: 3
[RESULT] Computation successful! Results:
[RESULT] f =
λ (param: integer) → error_empty
λ (param0: integer) → error_empty
⟨true ⊢
let result : RentComputation {"f": integer → integer} =
λ (RentComputation_in: RentComputation_in {}) →
let g : integer → integer = error_empty
(λ (param1: integer) → error_empty
⟨true ⊢ param1 +! 1⟩) in
(λ (param01: integer) → error_empty
⟨true ⊢ param01 +! 1⟩) in
let f : integer → integer = error_empty
(λ (param1: integer) → error_empty
⟨true ⊢ g param1 +! 1⟩) in
(λ (param01: integer) → error_empty
⟨true ⊢ g param01 +! 1⟩) in
RentComputation { "f"= f } RentComputation_in { } in
let result1 : RentComputation {"f": integer → integer} =
RentComputation { "f"=
λ (param1: integer) → result."f" param1 } in
if true then result1 else result1."f" param⟩
λ (param01: integer) → result."f" param01 } in
if true then result1 else result1."f" param0⟩
[RESULT] result = 3
```