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

Make scopes directly callable

Browse Source 
Quite a few changes are included here, some of which have some extra
implications visible in the language:

- adds the `Scope of { -- input_v: value; ... }` construct in the language

- handle it down the pipeline:
  * `ScopeCall` in the surface AST
  * `EScopeCall` in desugared and scopelang
  * expressions are now traversed to detect dependencies between scopes
  * transformed into a normal function call in dcalc

- defining a scope now implicitely defines a structure with the same name, with
  the output variables of the scope defined as fields. This allows us to type
  the return value from a scope call and access its fields easily.
  * the implications are mostly in surface/name_resolution.ml code-wise
  * the `Scope_out` struct that was defined in scope_to_dcalc is no longer
    needed/used and the fields are no longer renamed (changes some outputs; the
    explicit suffix for variables with multiple states is ignored as well)
  * one benefit is that disambiguation works just like for structures when there
    are conflicts on field names
  * however, it's now a conflict if a scope and a structure have the same
    name (side-note: issues with conflicting enum / struct names or scope
    variables / subscope names were silent and are now properly reported)

- you can consequently use scope names as types for variables as well. Writing
  literals is not allowed though, they can only be obtained by calling the
  scope.

Remaining TODOs:

- context variables are not handled properly at the moment

- error handling on invalid calls

- tests show a small error message regression; lots of examples will need
  tweaking to avoid scope/struct name or struct fields / output variable
  conflicts

- add a `->` syntax to make struct field access distinct from scope output var
  access, enforced with typing. This is expected to reduce confusion of users
  and add a little typing precision.

- document the new syntax & implications (tutorial, cheat-sheet)

- a consequence of the changes is that subscope variables also can now be typed.
  A possible future evolution / simplification would be to rewrite subscopes as
  explicit scope calls early in the pipeline. That could also allow to manipulate
  them as expressions (bind them in let-ins, return them...)
This commit is contained in:
Louis Gesbert 2022-10-21 15:47:17 +02:00
parent 7267543ca1
commit 41d6d3cbe9
31 changed files with 1213 additions and 994 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
compiler/desugared/desugared_to_scope.ml
View File

@ -74,14 +74,27 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr) :
| EVar v -> Expr.evar (Var.Map.find v ctx.var_mapping) m
| EStruct (s_name, fields) ->
Expr.estruct s_name (StructFieldMap.map (translate_expr ctx) fields) m
| EStructAccess (e1, s_name, f_name) ->
Expr.estructaccess (translate_expr ctx e1) s_name f_name m
| EStructAccess (e1, f_name, s_name) ->
Expr.estructaccess (translate_expr ctx e1) f_name s_name m
| EEnumInj (e1, cons, e_name) ->
Expr.eenuminj (translate_expr ctx e1) cons e_name m
| EMatchS (e1, e_name, arms) ->
Expr.ematchs (translate_expr ctx e1) e_name
(EnumConstructorMap.map (translate_expr ctx) arms)
m
| EScopeCall (sc_name, fields) ->
Expr.escopecall sc_name
(ScopeVarMap.fold
(fun v e fields' ->
let v' =
match ScopeVarMap.find v ctx.scope_var_mapping with
| WholeVar v' -> v'
| States _ ->
assert false (* TODO: what about input var states ?? *)
in
ScopeVarMap.add v' (translate_expr ctx e) fields')
fields ScopeVarMap.empty)
m
| ELit
(( LBool _ | LEmptyError | LInt _ | LRat _ | LMoney _ | LUnit | LDate _
| LDuration _ ) as l) ->

34
compiler/driver.ml
View File

@ -148,16 +148,24 @@ let driver source_file (options : Cli.options) : int =
| None, `Interpret ->
Errors.raise_error "No scope was provided for execution."
| None, _ ->
snd
(try Desugared.Ast.IdentMap.choose ctxt.scope_idmap
with Not_found ->
Errors.raise_error "There isn't any scope inside the program.")
let _, scope =
try
Desugared.Ast.IdentMap.filter_map
(fun _ -> function
| Surface.Name_resolution.TScope (uid, _) -> Some uid
| _ -> None)
ctxt.typedefs
|> Desugared.Ast.IdentMap.choose
with Not_found ->
Errors.raise_error "There isn't any scope inside the program."
in
scope
| Some name, _ -> (
match Desugared.Ast.IdentMap.find_opt name ctxt.scope_idmap with
| None ->
match Desugared.Ast.IdentMap.find_opt name ctxt.typedefs with
| Some (Surface.Name_resolution.TScope (uid, _)) -> uid
| _ ->
Errors.raise_error "There is no scope \"%s\" inside the program."
name
| Some uid -> uid)
name)
in
Cli.debug_print "Desugaring...";
let prgm = Surface.Desugaring.desugar_program ctxt prgm in
@ -255,16 +263,6 @@ let driver source_file (options : Cli.options) : int =
let results =
Dcalc.Interpreter.interpret_program prgm.decl_ctx prgrm_dcalc_expr
in
let out_regex = Re.Pcre.regexp "\\_out$" in
let results =
List.map
(fun ((v1, v1_pos), e1) ->
let v1 =
Re.Pcre.substitute ~rex:out_regex ~subst:(fun _ -> "") v1
in
(v1, v1_pos), e1)
results
in
let results =
List.sort
(fun ((v1, _), _) ((v2, _), _) -> String.compare v1 v2)

15
compiler/scopelang/ast.ml
View File

@ -75,8 +75,19 @@ let type_program (prg : 'm program) : typed program =
let typing_env =
ScopeMap.fold
(fun scope_name scope_decl ->
Typing.Env.add_scope scope_name
(ScopeVarMap.map fst scope_decl.scope_sig))
let input_vars, output_vars =
ScopeVarMap.fold
(fun var (typ, io) (input, output) ->
( (if Marked.unmark io.io_input <> NoInput then
ScopeVarMap.add var typ input
else input),
if Marked.unmark io.io_output then
ScopeVarMap.add var typ output
else output ))
scope_decl.scope_sig
(ScopeVarMap.empty, ScopeVarMap.empty)
in
Typing.Env.add_scope scope_name ~input_vars ~output_vars)
prg.program_scopes Typing.Env.empty
in
let program_scopes =

71
compiler/scopelang/dependency.ml
View File

@ -19,14 +19,7 @@
open Utils
open Shared_ast
module SVertex = struct
type t = ScopeName.t
let hash x = ScopeName.hash x
let compare = ScopeName.compare
let equal x y = ScopeName.compare x y = 0
end
module SVertex = ScopeName
(** On the edges, the label is the expression responsible for the use of the
function *)
@ -45,6 +38,29 @@ 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 recurse_subterms e =
Expr.shallow_fold
(fun e -> ScopeMap.union (fun _ x _ -> Some x) (expr_used_scopes e))
e ScopeMap.empty
in
match e with
| (EScopeCall (scope, _), m) as e ->
ScopeMap.add scope (Expr.mark_pos m) (recurse_subterms e)
| EAbs (binder, _), _ ->
let _, body = Bindlib.unmbind binder in
expr_used_scopes body
| e -> recurse_subterms e
let rule_used_scopes = 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
| Ast.Call (subscope, subindex, _) ->
ScopeMap.singleton subscope
(Marked.get_mark (SubScopeName.get_info subindex))
let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t =
let g = SDependencies.empty in
let g =
@ -54,30 +70,21 @@ let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t =
in
ScopeMap.fold
(fun scope_name scope g ->
let subscopes =
List.fold_left
(fun acc r ->
match r with
| Ast.Definition _ | Ast.Assertion _ -> acc
| Ast.Call (subscope, subindex, _) ->
if subscope = scope_name 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
else
ScopeMap.add subscope
(Marked.get_mark (SubScopeName.get_info subindex))
acc)
ScopeMap.empty scope.Ast.scope_decl_rules
in
ScopeMap.fold
(fun subscope pos g ->
let edge = SDependencies.E.create subscope pos scope_name in
SDependencies.add_edge_e g edge)
subscopes g)
List.fold_left
(fun g rule ->
let used_scopes = rule_used_scopes rule in
if ScopeMap.mem scope_name used_scopes then
Errors.raise_spanned_error
(Marked.get_mark (ScopeName.get_info scope.Ast.scope_decl_name))
"The scope %a is calling into itself as a subscope, which is \
forbidden since Catala does not provide recursion"
ScopeName.format_t scope.Ast.scope_decl_name;
ScopeMap.fold
(fun used_scope pos g ->
let edge = SDependencies.E.create used_scope pos scope_name in
SDependencies.add_edge_e g edge)
used_scopes g)
g scope.Ast.scope_decl_rules)
prgm.program_scopes g
let check_for_cycle_in_scope (g : SDependencies.t) : unit =

105
compiler/scopelang/scope_to_dcalc.ml
View File

@ -225,6 +225,30 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Ast.expr) :
else
let e1 = translate_expr ctx e1 in
Expr.ematch e1 d_cases enum_name m
| EScopeCall (sc_name, fields) ->
let pos = Expr.mark_pos m in
let sc_sig = ScopeMap.find sc_name ctx.scopes_parameters in
let struct_def = StructMap.find sc_sig.scope_sig_input_struct ctx.structs in
let struct_fields =
(* Fixme: the correspondance of the two lists is fragile (see also the
conversion of [Call] *)
List.map2
(fun (sc_var, e) (fld_name, _ty) ->
(* pretty weak check, but better than nothing for now *)
assert (
Marked.unmark (ScopeVar.get_info sc_var) ^ "_in"
= Marked.unmark (StructFieldName.get_info fld_name));
translate_expr ctx e)
(ScopeVarMap.bindings fields)
struct_def
in
let arg_struct =
Expr.etuple struct_fields (Some sc_sig.scope_sig_input_struct)
(mark_tany m pos)
in
Expr.eapp
(Expr.evar sc_sig.scope_sig_scope_var (mark_tany m pos))
[arg_struct] m
| EApp (e1, args) ->
(* We insert various log calls to record arguments and outputs of
user-defined functions belonging to scopes *)
@ -496,6 +520,8 @@ let translate_rule
all_subscope_input_vars
in
let subscope_struct_arg =
(* FIXME: this is very fragile: we assume that the ordering of the scope
variables is the same as the ordering of the struct fields. *)
Expr.etuple subscope_args (Some called_scope_input_struct)
(mark_tany m pos_call)
in
@ -708,11 +734,6 @@ let translate_scope_decl
| _ -> true)
scope_variables
in
let scope_output_variables =
List.filter
(fun (var_ctx, _) -> Marked.unmark var_ctx.scope_var_io.io_output)
scope_variables
in
let input_var_typ (var_ctx : scope_var_ctx) =
match Marked.unmark var_ctx.scope_var_io.io_input with
| OnlyInput -> var_ctx.scope_var_typ, pos_sigma
@ -751,15 +772,6 @@ let translate_scope_decl
scope_input_variables
(next, List.length scope_input_variables - 1))
in
let scope_return_struct_fields =
List.map
(fun (var_ctx, dvar) ->
let struct_field_name =
StructFieldName.fresh (Bindlib.name_of dvar ^ "_out", pos_sigma)
in
struct_field_name, (var_ctx.scope_var_typ, pos_sigma))
scope_output_variables
in
let scope_input_struct_fields =
List.map
(fun (var_ctx, dvar) ->
@ -770,8 +782,7 @@ let translate_scope_decl
scope_input_variables
in
let new_struct_ctx =
StructMap.add scope_input_struct_name scope_input_struct_fields
(StructMap.singleton scope_return_struct_name scope_return_struct_fields)
StructMap.singleton scope_input_struct_name scope_input_struct_fields
in
( Bindlib.box_apply
(fun scope_body_expr ->
@ -797,10 +808,7 @@ let translate_program (prgm : 'm Ast.program) : 'm Dcalc.Ast.program =
(Marked.unmark (ScopeName.get_info scope.Ast.scope_decl_name))
in
let scope_return_struct_name =
StructName.fresh
(Marked.map_under_mark
(fun s -> s ^ "_out")
(ScopeName.get_info scope_name))
ScopeMap.find scope_name decl_ctx.ctx_scopes
in
let scope_input_var =
Var.make (Marked.unmark (ScopeName.get_info scope_name) ^ "_in")
@ -829,34 +837,33 @@ let translate_program (prgm : 'm Ast.program) : 'm Dcalc.Ast.program =
prgm.program_scopes
in
(* the resulting expression is the list of definitions of all the scopes,
ending with the top-level scope. *)
let (scopes, decl_ctx) : 'm Dcalc.Ast.expr scopes Bindlib.box * _ =
List.fold_right
(fun scope_name (scopes, decl_ctx) ->
let scope = ScopeMap.find scope_name prgm.program_scopes in
let scope_body, scope_out_struct =
translate_scope_decl decl_ctx.ctx_structs decl_ctx.ctx_enums sctx
scope_name scope
in
let dvar = (ScopeMap.find scope_name sctx).scope_sig_scope_var in
let decl_ctx =
{
decl_ctx with
ctx_structs =
StructMap.union
(fun _ _ -> assert false (* should not happen *))
decl_ctx.ctx_structs scope_out_struct;
}
in
let scope_next = Bindlib.bind_var dvar scopes in
let new_scopes =
Bindlib.box_apply2
(fun scope_body scope_next ->
ScopeDef { scope_name; scope_body; scope_next })
scope_body scope_next
in
new_scopes, decl_ctx)
scope_ordering
(Bindlib.box Nil, decl_ctx)
ending with the top-level scope. The decl_ctx is allocated 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 = ScopeMap.find scope_name prgm.program_scopes in
let scope_body, scope_in_struct =
translate_scope_decl decl_ctx.ctx_structs decl_ctx.ctx_enums sctx
scope_name scope
in
let dvar = (ScopeMap.find scope_name sctx).scope_sig_scope_var in
let decl_ctx =
{
decl_ctx with
ctx_structs =
StructMap.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
( 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
in
let scopes, decl_ctx = translate_scopes decl_ctx scope_ordering in
{ scopes = Bindlib.unbox scopes; decl_ctx }

13
compiler/shared_ast/definitions.ml
View File

@ -26,6 +26,7 @@ module Runtime = Runtime_ocaml.Runtime
module ScopeName : Uid.Id with type info = Uid.MarkedString.info =
Uid.Make (Uid.MarkedString) ()
module ScopeSet : Set.S with type elt = ScopeName.t = Set.Make (ScopeName)
module ScopeMap : Map.S with type key = ScopeName.t = Map.Make (ScopeName)
module StructName : Uid.Id with type info = Uid.MarkedString.info =
@ -222,6 +223,9 @@ and ('a, 't) naked_gexpr =
| EMatchS :
('a, 't) gexpr * EnumName.t * ('a, 't) gexpr EnumConstructorMap.t
-> (([< desugared | scopelang ] as 'a), 't) naked_gexpr
| EScopeCall :
ScopeName.t * ('a, 't) gexpr ScopeVarMap.t
-> (([< desugared | scopelang ] as 'a), 't) naked_gexpr
(* Lambda-like *)
| ETuple :
('a, 't) gexpr list * StructName.t option
@ -348,5 +352,12 @@ and 'e scopes =
type struct_ctx = (StructFieldName.t * typ) list StructMap.t
type enum_ctx = (EnumConstructor.t * typ) list EnumMap.t
type decl_ctx = { ctx_enums : enum_ctx; ctx_structs : struct_ctx }
type decl_ctx = {
ctx_enums : enum_ctx;
ctx_structs : struct_ctx;
ctx_scopes : StructName.t ScopeMap.t;
(** The output structure type of every scope *)
}
type 'e program = { decl_ctx : decl_ctx; scopes : 'e scopes }

20
compiler/shared_ast/expr.ml
View File

@ -126,6 +126,12 @@ let ematchs e1 enum cases mark =
(Box.lift e1)
(Box.lift_enum (EnumConstructorMap.map Box.lift cases))
let escopecall scope_name fields mark =
Marked.mark mark
@@ Bindlib.box_apply
(fun fields -> EScopeCall (scope_name, fields))
(Box.lift_scope_vars (ScopeVarMap.map Box.lift fields))
(* - Manipulation of marks - *)
let no_mark : type m. m mark -> m mark = function
@ -235,6 +241,9 @@ let map
| EMatchS (e1, enum, cases) ->
let cases = EnumConstructorMap.map (f ctx) cases in
ematchs (f ctx e1) enum cases m
| EScopeCall (scope_name, fields) ->
let fields = ScopeVarMap.map (f ctx) fields in
escopecall scope_name fields m
let rec map_top_down ~f e = map () ~f:(fun () -> map_top_down ~f) (f e)
@ -268,6 +277,7 @@ let shallow_fold
| EEnumInj (e1, _, _) -> acc |> f e1
| EMatchS (e1, _, cases) ->
acc |> f e1 |> EnumConstructorMap.fold (fun _ -> f) cases
| EScopeCall (_, fields) -> acc |> ScopeVarMap.fold (fun _ -> f) fields
(* - *)
@ -595,10 +605,12 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool =
EnumName.equal n1 n2
&& equal e1 e2
&& EnumConstructorMap.equal equal cases1 cases2
| EScopeCall (s1, fields1), EScopeCall (s2, fields2) ->
ScopeName.equal s1 s2 && ScopeVarMap.equal equal fields1 fields2
| ( ( EVar _ | ETuple _ | ETupleAccess _ | EInj _ | EMatch _ | EArray _
| ELit _ | EAbs _ | EApp _ | EAssert _ | EOp _ | EDefault _
| EIfThenElse _ | ErrorOnEmpty _ | ERaise _ | ECatch _ | ELocation _
| EStruct _ | EStructAccess _ | EEnumInj _ | EMatchS _ ),
| EStruct _ | EStructAccess _ | EEnumInj _ | EMatchS _ | EScopeCall _ ),
_ ) ->
false
@ -646,6 +658,9 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
compare e1 e2 @@< fun () ->
EnumName.compare name1 name2 @@< fun () ->
EnumConstructorMap.compare compare emap1 emap2
| EScopeCall (name1, field_map1), EScopeCall (name2, field_map2) ->
ScopeName.compare name1 name2 @@< fun () ->
ScopeVarMap.compare compare field_map1 field_map2
| ETuple (es1, s1), ETuple (es2, s2) ->
Option.compare StructName.compare s1 s2 @@< fun () ->
List.compare compare es1 es2
@ -689,6 +704,7 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
| EStructAccess _, _ -> -1 | _, EStructAccess _ -> 1
| EEnumInj _, _ -> -1 | _, EEnumInj _ -> 1
| EMatchS _, _ -> -1 | _, EMatchS _ -> 1
| EScopeCall _, _ -> -1 | _, EScopeCall _ -> 1
| ETuple _, _ -> -1 | _, ETuple _ -> 1
| ETupleAccess _, _ -> -1 | _, ETupleAccess _ -> 1
| EInj _, _ -> -1 | _, EInj _ -> 1
@ -748,6 +764,8 @@ let rec size : type a. (a, 't) gexpr -> int =
| EEnumInj (e1, _, _) -> 1 + size e1
| EMatchS (e1, _, cases) ->
EnumConstructorMap.fold (fun _ e acc -> acc + 1 + size e) cases (size e1)
| EScopeCall (_, fields) ->
ScopeVarMap.fold (fun _ e acc -> acc + 1 + size e) fields 1
(* - Expression building helpers - *)

6
compiler/shared_ast/expr.mli
View File

@ -150,6 +150,12 @@ val ematchs :
't ->
('a, 't) boxed_gexpr
val escopecall :
ScopeName.t ->
(([< desugared | scopelang ] as 'a), 't) boxed_gexpr ScopeVarMap.t ->
't ->
('a, 't) boxed_gexpr
(** Manipulation of marks *)
val no_mark : 'm mark -> 'm mark

18
compiler/shared_ast/print.ml
View File

@ -397,6 +397,24 @@ let rec expr_aux :
Format.fprintf fmt "@[<hov 2>%a %a@ %a@ %a@]" punctuation "|"
enum_constructor cons_name punctuation "→" expr case_expr))
(EnumConstructorMap.bindings cases)
| EScopeCall (scope, fields) ->
Format.pp_open_hovbox fmt 2;
ScopeName.format_t fmt scope;
Format.pp_print_space fmt ();
keyword fmt "of";
Format.pp_print_space fmt ();
Format.pp_open_hvbox fmt 2;
punctuation fmt "{";
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "%a@ " punctuation ";")
(fun fmt (field_name, field_expr) ->
Format.fprintf fmt "%a%a%a%a@ %a" punctuation "\"" ScopeVar.format_t
field_name punctuation "\"" punctuation "=" expr field_expr)
fmt
(ScopeVarMap.bindings fields);
Format.pp_close_box fmt ();
punctuation fmt "}";
Format.pp_close_box fmt ()
let typ_debug = typ None
let typ ctx = typ (Some ctx)

28
compiler/shared_ast/typing.ml
View File

@ -284,7 +284,8 @@ module Env = struct
type 'e t = {
vars : ('e, unionfind_typ) Var.Map.t;
scope_vars : A.typ A.ScopeVarMap.t;
scopes : A.typ A.ScopeVarMap.t A.ScopeMap.t;
scopes : (A.typ A.ScopeVarMap.t * A.typ A.ScopeVarMap.t) A.ScopeMap.t;
(* input * output *)
}
let empty =
@ -297,8 +298,8 @@ module Env = struct
let get t v = Var.Map.find_opt v t.vars
let get_scope_var t sv = A.ScopeVarMap.find_opt sv t.scope_vars
let get_subscope_var t scope var =
Option.bind (A.ScopeMap.find_opt scope t.scopes) (fun vmap ->
let get_subscope_out_var t scope var =
Option.bind (A.ScopeMap.find_opt scope t.scopes) (fun (_, vmap) ->
A.ScopeVarMap.find_opt var vmap)
let add v tau t = { t with vars = Var.Map.add v tau t.vars }
@ -307,8 +308,11 @@ module Env = struct
let add_scope_var v typ t =
{ t with scope_vars = A.ScopeVarMap.add v typ t.scope_vars }
let add_scope scope_name vmap t =
{ t with scopes = A.ScopeMap.add scope_name vmap t.scopes }
let add_scope scope_name ~input_vars ~output_vars t =
{
t with
scopes = A.ScopeMap.add scope_name (input_vars, output_vars) t.scopes;
}
end
let add_pos e ty = Marked.mark (Expr.pos e) ty
@ -360,7 +364,7 @@ and typecheck_expr_top_down :
| DesugaredScopeVar (v, _) | ScopelangScopeVar v ->
Env.get_scope_var env (Marked.unmark v)
| SubScopeVar (scope, _, v) ->
Env.get_subscope_var env scope (Marked.unmark v)
Env.get_subscope_out_var env scope (Marked.unmark v)
in
let ty =
match ty_opt with
@ -415,6 +419,18 @@ and typecheck_expr_top_down :
cases
in
Expr.ematchs e1' e_name cases' mark
| A.EScopeCall (scope_name, fields) ->
let scope_out_struct = A.ScopeMap.find scope_name ctx.ctx_scopes in
let mark = uf_mark (unionfind (TStruct scope_out_struct)) in
let vars_in, _vars_out = A.ScopeMap.find scope_name env.scopes in
let fields' =
A.ScopeVarMap.mapi
(fun name ->
typecheck_expr_top_down ctx env
(ast_to_typ (A.ScopeVarMap.find name vars_in)))
fields
in
Expr.escopecall scope_name fields' mark
| A.ERaise ex -> Expr.eraise ex context_mark
| A.ECatch (e1, ex, e2) ->
let e1' = typecheck_expr_top_down ctx env tau e1 in

8
compiler/shared_ast/typing.mli
View File

@ -25,7 +25,13 @@ module Env : sig
val empty : 'e t
val add_var : 'e Var.t -> typ -> 'e t -> 'e t
val add_scope_var : ScopeVar.t -> typ -> 'e t -> 'e t
val add_scope : ScopeName.t -> typ ScopeVarMap.t -> 'e t -> 'e t
val add_scope :
ScopeName.t ->
input_vars:typ ScopeVarMap.t ->
output_vars:typ ScopeVarMap.t ->
'e t ->
'e t
end
val expr :

2
compiler/surface/ast.ml
View File

@ -423,6 +423,8 @@ and expression =
| MemCollection of expression Marked.pos * expression Marked.pos
| TestMatchCase of expression Marked.pos * match_case_pattern Marked.pos
| FunCall of expression Marked.pos * expression Marked.pos
| ScopeCall of
constructor Marked.pos * (ident Marked.pos * expression Marked.pos) list
| LetIn of ident Marked.pos * expression Marked.pos * expression Marked.pos
| Builtin of builtin_expression
| Literal of literal

302
compiler/surface/desugaring.ml
View File

@ -102,9 +102,7 @@ let disambiguate_constructor
| Some enum -> (
try
(* The path is fully qualified *)
let e_uid =
Desugared.Ast.IdentMap.find (Marked.unmark enum) ctxt.enum_idmap
in
let e_uid = Name_resolution.get_enum ctxt enum in
try
let c_uid = EnumMap.find e_uid possible_c_uids in
e_uid, c_uid
@ -118,7 +116,7 @@ let disambiguate_constructor
(** Usage: [translate_expr scope ctxt naked_expr]
Translates [naked_expr] into its desugared equivalent. [scope] is used to
Translates [expr] into its desugared equivalent. [scope] is used to
disambiguate the scope and subscopes variables than occur in the expression *)
let rec translate_expr
(scope : ScopeName.t)
@ -218,7 +216,7 @@ let rec translate_expr
match Desugared.Ast.IdentMap.find_opt x ctxt.local_var_idmap with
| None -> (
match Desugared.Ast.IdentMap.find_opt x scope_ctxt.var_idmap with
| Some uid ->
| Some (ScopeVar uid) ->
(* If the referenced variable has states, then here are the rules to
desambiguate. In general, only the last state can be referenced.
Except if defining a state of the same variable, then it references
@ -258,7 +256,7 @@ let rec translate_expr
Some (List.hd (List.rev states)))
in
Expr.elocation (DesugaredScopeVar ((uid, pos), x_state)) emark
| None ->
| Some (SubScope _) | None ->
Name_resolution.raise_unknown_identifier
"for a local or scope-wide variable" (x, pos))
| Some uid ->
@ -268,11 +266,10 @@ let rec translate_expr
match Marked.unmark e with
| Ident y when Name_resolution.is_subscope_uid scope ctxt y ->
(* In this case, y.x is a subscope variable *)
let subscope_uid : SubScopeName.t =
Name_resolution.get_subscope_uid scope ctxt (Marked.same_mark_as y e)
in
let subscope_real_uid : ScopeName.t =
SubScopeMap.find subscope_uid scope_ctxt.sub_scopes
let subscope_uid, subscope_real_uid =
match Desugared.Ast.IdentMap.find y scope_ctxt.var_idmap with
| SubScope (sub, sc) -> sub, sc
| ScopeVar _ -> assert false
in
let subscope_var_uid =
Name_resolution.get_var_uid subscope_real_uid ctxt x
@ -307,9 +304,7 @@ let rec translate_expr
Expr.estructaccess e f_uid s_uid emark
| Some c_name -> (
try
let c_uid =
Desugared.Ast.IdentMap.find (Marked.unmark c_name) ctxt.struct_idmap
in
let c_uid = Name_resolution.get_struct ctxt c_name in
try
let f_uid = StructMap.find c_uid x_possible_structs in
Expr.estructaccess e f_uid c_uid emark
@ -320,6 +315,24 @@ let rec translate_expr
Errors.raise_spanned_error (Marked.get_mark c_name)
"Struct %s has not been defined before" (Marked.unmark c_name))))
| FunCall (f, arg) -> Expr.eapp (rec_helper f) [rec_helper arg] emark
| ScopeCall (sc_name, fields) ->
let called_scope = Name_resolution.get_scope ctxt sc_name in
let scope_def = ScopeMap.find called_scope ctxt.scopes in
let in_struct =
List.fold_left
(fun acc (fld_id, e) ->
let var =
match
Desugared.Ast.IdentMap.find (Marked.unmark fld_id)
scope_def.var_idmap
with
| ScopeVar v -> v
| SubScope _ -> assert false
in
ScopeVarMap.add var (rec_helper e) acc)
ScopeVarMap.empty fields
in
Expr.escopecall called_scope in_struct emark
| LetIn (x, e1, e2) ->
let ctxt, v = Name_resolution.add_def_local_var ctxt (Marked.unmark x) in
let tau = TAny, Marked.get_mark x in
@ -331,8 +344,11 @@ let rec translate_expr
Expr.eapp fn [rec_helper e1] emark
| StructLit (s_name, fields) ->
let s_uid =
try Desugared.Ast.IdentMap.find (Marked.unmark s_name) ctxt.struct_idmap
with Not_found ->
match
Desugared.Ast.IdentMap.find_opt (Marked.unmark s_name) ctxt.typedefs
with
| Some (Name_resolution.TStruct s_uid) -> s_uid
| _ ->
Errors.raise_spanned_error (Marked.get_mark s_name)
"This identifier should refer to a struct name"
in
@ -408,9 +424,7 @@ let rec translate_expr
| Some enum -> (
try
(* The path has been fully qualified *)
let e_uid =
Desugared.Ast.IdentMap.find (Marked.unmark enum) ctxt.enum_idmap
in
let e_uid = Name_resolution.get_enum ctxt enum in
try
let c_uid = EnumMap.find e_uid possible_c_uids in
let payload =
@ -1092,8 +1106,7 @@ let process_scope_use
(ctxt : Name_resolution.context)
(prgm : Desugared.Ast.program)
(use : Ast.scope_use) : Desugared.Ast.program =
let name = fst use.scope_use_name in
let scope_uid = Desugared.Ast.IdentMap.find name ctxt.scope_idmap in
let scope_uid = Name_resolution.get_scope ctxt use.scope_use_name in
(* Make sure the scope exists *)
let prgm =
match ScopeMap.find_opt scope_uid prgm.program_scopes with
@ -1120,10 +1133,127 @@ let attribute_to_io (attr : Ast.scope_decl_context_io) : Scopelang.Ast.io =
attr.scope_decl_context_io_input;
}
let init_scope_defs ctxt scope_idmap =
(* Initializing the definitions of all scopes and subscope vars, with no rules
yet inside *)
let add_def _ v scope_def_map =
match v with
| Name_resolution.ScopeVar v -> (
let v_sig = ScopeVarMap.find v ctxt.Name_resolution.var_typs in
match v_sig.var_sig_states_list with
| [] ->
let def_key = Desugared.Ast.ScopeDef.Var (v, None) in
Desugared.Ast.ScopeDefMap.add def_key
{
Desugared.Ast.scope_def_rules = Desugared.Ast.RuleMap.empty;
Desugared.Ast.scope_def_typ = v_sig.var_sig_typ;
Desugared.Ast.scope_def_is_condition = v_sig.var_sig_is_condition;
Desugared.Ast.scope_def_io = attribute_to_io v_sig.var_sig_io;
}
scope_def_map
| states ->
let scope_def, _ =
List.fold_left
(fun (acc, i) state ->
let def_key = Desugared.Ast.ScopeDef.Var (v, Some state) in
let def =
{
Desugared.Ast.scope_def_rules = Desugared.Ast.RuleMap.empty;
Desugared.Ast.scope_def_typ = v_sig.var_sig_typ;
Desugared.Ast.scope_def_is_condition =
v_sig.var_sig_is_condition;
Desugared.Ast.scope_def_io =
(* The first state should have the input I/O of the original
variable, and the last state should have the output I/O
of the original variable. All intermediate states shall
have "internal" I/O.*)
(let original_io = attribute_to_io v_sig.var_sig_io in
let io_input =
if i = 0 then original_io.io_input
else
( Scopelang.Ast.NoInput,
Marked.get_mark (StateName.get_info state) )
in
let io_output =
if i = List.length states - 1 then original_io.io_output
else false, Marked.get_mark (StateName.get_info state)
in
{ io_input; io_output });
}
in
Desugared.Ast.ScopeDefMap.add def_key def acc, i + 1)
(scope_def_map, 0) states
in
scope_def)
| Name_resolution.SubScope (v0, subscope_uid) ->
let sub_scope_def =
ScopeMap.find subscope_uid ctxt.Name_resolution.scopes
in
Desugared.Ast.IdentMap.fold
(fun _ v scope_def_map ->
match v with
| Name_resolution.SubScope _ -> scope_def_map
| Name_resolution.ScopeVar v ->
(* TODO: shouldn't we ignore internal variables too at this point
? *)
let v_sig = ScopeVarMap.find v ctxt.Name_resolution.var_typs in
let def_key =
Desugared.Ast.ScopeDef.SubScopeVar
(v0, v, Marked.get_mark (ScopeVar.get_info v))
in
Desugared.Ast.ScopeDefMap.add def_key
{
Desugared.Ast.scope_def_rules = Desugared.Ast.RuleMap.empty;
Desugared.Ast.scope_def_typ = v_sig.var_sig_typ;
Desugared.Ast.scope_def_is_condition =
v_sig.var_sig_is_condition;
Desugared.Ast.scope_def_io = attribute_to_io v_sig.var_sig_io;
}
scope_def_map)
sub_scope_def.Name_resolution.var_idmap scope_def_map
in
Desugared.Ast.IdentMap.fold add_def scope_idmap
Desugared.Ast.ScopeDefMap.empty
(** Main function of this module *)
let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) :
Desugared.Ast.program =
let empty_prgm =
let program_scopes =
ScopeMap.mapi
(fun s_uid s_context ->
let scope_vars =
Desugared.Ast.IdentMap.fold
(fun _ v acc ->
match v with
| Name_resolution.SubScope _ -> acc
| Name_resolution.ScopeVar v -> (
let v_sig = ScopeVarMap.find v ctxt.var_typs in
match v_sig.var_sig_states_list with
| [] -> ScopeVarMap.add v Desugared.Ast.WholeVar acc
| states ->
ScopeVarMap.add v (Desugared.Ast.States states) acc))
s_context.Name_resolution.var_idmap ScopeVarMap.empty
in
let scope_sub_scopes =
Desugared.Ast.IdentMap.fold
(fun _ v acc ->
match v with
| Name_resolution.ScopeVar _ -> acc
| Name_resolution.SubScope (sub_var, sub_scope) ->
SubScopeMap.add sub_var sub_scope acc)
s_context.Name_resolution.var_idmap SubScopeMap.empty
in
{
Desugared.Ast.scope_vars;
scope_sub_scopes;
scope_defs = init_scope_defs ctxt s_context.var_idmap;
scope_assertions = [];
scope_meta_assertions = [];
scope_uid = s_uid;
})
ctxt.Name_resolution.scopes
in
{
Desugared.Ast.program_ctx =
{
@ -1131,128 +1261,16 @@ let desugar_program (ctxt : Name_resolution.context) (prgm : Ast.program) :
StructMap.map StructFieldMap.bindings ctxt.Name_resolution.structs;
ctx_enums =
EnumMap.map EnumConstructorMap.bindings ctxt.Name_resolution.enums;
ctx_scopes =
Desugared.Ast.IdentMap.fold
(fun _ def acc ->
match def with
| Name_resolution.TScope (scope, struc) ->
ScopeMap.add scope struc acc
| _ -> acc)
ctxt.Name_resolution.typedefs ScopeMap.empty;
};
Desugared.Ast.program_scopes =
ScopeMap.mapi
(fun s_uid s_context ->
{
Desugared.Ast.scope_vars =
Desugared.Ast.IdentMap.fold
(fun _ v acc ->
let v_sig = ScopeVarMap.find v ctxt.var_typs in
match v_sig.var_sig_states_list with
| [] -> ScopeVarMap.add v Desugared.Ast.WholeVar acc
| states ->
ScopeVarMap.add v (Desugared.Ast.States states) acc)
s_context.Name_resolution.var_idmap ScopeVarMap.empty;
Desugared.Ast.scope_sub_scopes =
s_context.Name_resolution.sub_scopes;
Desugared.Ast.scope_defs =
(* Initializing the definitions of all scopes and subscope vars,
with no rules yet inside *)
(let scope_vars_defs =
Desugared.Ast.IdentMap.fold
(fun _ v acc ->
let v_sig =
ScopeVarMap.find v ctxt.Name_resolution.var_typs
in
match v_sig.var_sig_states_list with
| [] ->
let def_key = Desugared.Ast.ScopeDef.Var (v, None) in
Desugared.Ast.ScopeDefMap.add def_key
{
Desugared.Ast.scope_def_rules =
Desugared.Ast.RuleMap.empty;
Desugared.Ast.scope_def_typ = v_sig.var_sig_typ;
Desugared.Ast.scope_def_is_condition =
v_sig.var_sig_is_condition;
Desugared.Ast.scope_def_io =
attribute_to_io v_sig.var_sig_io;
}
acc
| states ->
fst
(List.fold_left
(fun (acc, i) state ->
let def_key =
Desugared.Ast.ScopeDef.Var (v, Some state)
in
( Desugared.Ast.ScopeDefMap.add def_key
{
Desugared.Ast.scope_def_rules =
Desugared.Ast.RuleMap.empty;
Desugared.Ast.scope_def_typ =
v_sig.var_sig_typ;
Desugared.Ast.scope_def_is_condition =
v_sig.var_sig_is_condition;
Desugared.Ast.scope_def_io =
(* The first state should have the input
I/O of the original variable, and the
last state should have the output I/O
of the original variable. All
intermediate states shall have
"internal" I/O.*)
(let original_io =
attribute_to_io v_sig.var_sig_io
in
let io_input =
if i = 0 then original_io.io_input
else
( Scopelang.Ast.NoInput,
Marked.get_mark
(StateName.get_info state) )
in
let io_output =
if i = List.length states - 1 then
original_io.io_output
else
( false,
Marked.get_mark
(StateName.get_info state) )
in
{ io_input; io_output });
}
acc,
i + 1 ))
(acc, 0) states))
s_context.Name_resolution.var_idmap
Desugared.Ast.ScopeDefMap.empty
in
let scope_and_subscope_vars_defs =
SubScopeMap.fold
(fun subscope_name subscope_uid acc ->
Desugared.Ast.IdentMap.fold
(fun _ v acc ->
let v_sig =
ScopeVarMap.find v ctxt.Name_resolution.var_typs
in
let def_key =
Desugared.Ast.ScopeDef.SubScopeVar
( subscope_name,
v,
Marked.get_mark (ScopeVar.get_info v) )
in
Desugared.Ast.ScopeDefMap.add def_key
{
Desugared.Ast.scope_def_rules =
Desugared.Ast.RuleMap.empty;
Desugared.Ast.scope_def_typ = v_sig.var_sig_typ;
Desugared.Ast.scope_def_is_condition =
v_sig.var_sig_is_condition;
Desugared.Ast.scope_def_io =
attribute_to_io v_sig.var_sig_io;
}
acc)
(ScopeMap.find subscope_uid ctxt.Name_resolution.scopes)
.Name_resolution.var_idmap acc)
s_context.sub_scopes scope_vars_defs
in
scope_and_subscope_vars_defs);
Desugared.Ast.scope_assertions = [];
Desugared.Ast.scope_meta_assertions = [];
Desugared.Ast.scope_uid = s_uid;
})
ctxt.Name_resolution.scopes;
Desugared.Ast.program_scopes;
}
in
let rec processer_structure

367
compiler/surface/name_resolution.ml
View File

@ -34,14 +34,17 @@ type scope_def_context = {
label_idmap : Desugared.Ast.LabelName.t Desugared.Ast.IdentMap.t;
}
type scope_var_or_subscope =
| ScopeVar of ScopeVar.t
| SubScope of SubScopeName.t * ScopeName.t
type scope_context = {
var_idmap : ScopeVar.t Desugared.Ast.IdentMap.t; (** Scope variables *)
var_idmap : scope_var_or_subscope Desugared.Ast.IdentMap.t;
(** All variables, including scope variables and subscopes *)
scope_defs_contexts : scope_def_context Desugared.Ast.ScopeDefMap.t;
(** What is the default rule to refer to for unnamed exceptions, if any *)
sub_scopes_idmap : SubScopeName.t Desugared.Ast.IdentMap.t;
(** Sub-scopes variables *)
sub_scopes : ScopeName.t SubScopeMap.t;
(** To what scope sub-scopes refer to? *)
sub_scopes : ScopeSet.t;
(** Other scopes referred to by this scope. Used for dependency analysis *)
}
(** Inside a scope, we distinguish between the variables and the subscopes. *)
@ -59,19 +62,23 @@ type var_sig = {
var_sig_states_list : StateName.t list;
}
(** Capitalised type names share a namespace on the user side, but may
correspond to only one of the following *)
type typedef =
| TStruct of StructName.t
| TEnum of EnumName.t
| TScope of ScopeName.t * StructName.t
(** Implicitly defined output struct *)
type context = {
local_var_idmap : Desugared.Ast.expr Var.t Desugared.Ast.IdentMap.t;
(** Inside a definition, local variables can be introduced by functions
arguments or pattern matching *)
scope_idmap : ScopeName.t Desugared.Ast.IdentMap.t;
(** The names of the scopes *)
struct_idmap : StructName.t Desugared.Ast.IdentMap.t;
(** The names of the structs *)
typedefs : typedef Desugared.Ast.IdentMap.t;
(** Gathers the names of the scopes, structs and enums *)
field_idmap : StructFieldName.t StructMap.t Desugared.Ast.IdentMap.t;
(** The names of the struct fields. Names of fields can be shared between
different structs *)
enum_idmap : EnumName.t Desugared.Ast.IdentMap.t;
(** The names of the enums *)
constructor_idmap : EnumConstructor.t EnumMap.t Desugared.Ast.IdentMap.t;
(** The names of the enum constructors. Constructor names can be shared
between different enums *)
@ -115,11 +122,11 @@ let get_var_uid
((x, pos) : ident Marked.pos) : ScopeVar.t =
let scope = ScopeMap.find scope_uid ctxt.scopes in
match Desugared.Ast.IdentMap.find_opt x scope.var_idmap with
| None ->
| Some (ScopeVar uid) -> uid
| _ ->
raise_unknown_identifier
(Format.asprintf "for a variable of scope %a" ScopeName.format_t scope_uid)
(x, pos)
| Some uid -> uid
(** Get the subscope uid inside the scope given in argument *)
let get_subscope_uid
@ -127,23 +134,27 @@ let get_subscope_uid
(ctxt : context)
((y, pos) : ident Marked.pos) : SubScopeName.t =
let scope = ScopeMap.find scope_uid ctxt.scopes in
match Desugared.Ast.IdentMap.find_opt y scope.sub_scopes_idmap with
| None -> raise_unknown_identifier "for a subscope of this scope" (y, pos)
| Some sub_uid -> sub_uid
match Desugared.Ast.IdentMap.find_opt y scope.var_idmap with
| Some (SubScope (sub_uid, _sub_id)) -> sub_uid
| _ -> raise_unknown_identifier "for a subscope of this scope" (y, pos)
(** [is_subscope_uid scope_uid ctxt y] returns true if [y] belongs to the
subscopes of [scope_uid]. *)
let is_subscope_uid (scope_uid : ScopeName.t) (ctxt : context) (y : ident) :
bool =
let scope = ScopeMap.find scope_uid ctxt.scopes in
Desugared.Ast.IdentMap.mem y scope.sub_scopes_idmap
match Desugared.Ast.IdentMap.find_opt y scope.var_idmap with
| Some (SubScope _) -> true
| _ -> false
(** Checks if the var_uid belongs to the scope scope_uid *)
let belongs_to (ctxt : context) (uid : ScopeVar.t) (scope_uid : ScopeName.t) :
bool =
let scope = ScopeMap.find scope_uid ctxt.scopes in
Desugared.Ast.IdentMap.exists
(fun _ var_uid -> ScopeVar.compare uid var_uid = 0)
(fun _ -> function
| ScopeVar var_uid -> ScopeVar.equal uid var_uid
| _ -> false)
scope.var_idmap
(** Retrieves the type of a scope definition from the context *)
@ -163,6 +174,62 @@ let is_def_cond (ctxt : context) (def : Desugared.Ast.ScopeDef.t) : bool =
| Desugared.Ast.ScopeDef.Var (x, _) ->
is_var_cond ctxt x
let get_enum ctxt id =
match Desugared.Ast.IdentMap.find (Marked.unmark id) ctxt.typedefs with
| TEnum id -> id
| TStruct sid ->
Errors.raise_multispanned_error
[
None, Marked.get_mark id;
Some "Structure defined at", Marked.get_mark (StructName.get_info sid);
]
"Expecting an enum, but found a structure"
| TScope (sid, _) ->
Errors.raise_multispanned_error
[
None, Marked.get_mark id;
Some "Scope defined at", Marked.get_mark (ScopeName.get_info sid);
]
"Expecting an enum, but found a scope"
| exception Not_found ->
Errors.raise_spanned_error (Marked.get_mark id) "No enum named %s found"
(Marked.unmark id)
let get_struct ctxt id =
match Desugared.Ast.IdentMap.find (Marked.unmark id) ctxt.typedefs with
| TStruct id | TScope (_, id) -> id
| TEnum eid ->
Errors.raise_multispanned_error
[
None, Marked.get_mark id;
Some "Enum defined at", Marked.get_mark (EnumName.get_info eid);
]
"Expecting an struct, but found an enum"
| exception Not_found ->
Errors.raise_spanned_error (Marked.get_mark id) "No struct named %s found"
(Marked.unmark id)
let get_scope ctxt id =
match Desugared.Ast.IdentMap.find (Marked.unmark id) ctxt.typedefs with
| TScope (id, _) -> id
| TEnum eid ->
Errors.raise_multispanned_error
[
None, Marked.get_mark id;
Some "Enum defined at", Marked.get_mark (EnumName.get_info eid);
]
"Expecting an scope, but found an enum"
| TStruct sid ->
Errors.raise_multispanned_error
[
None, Marked.get_mark id;
Some "Structure defined at", Marked.get_mark (StructName.get_info sid);
]
"Expecting an scope, but found a structure"
| exception Not_found ->
Errors.raise_spanned_error (Marked.get_mark id) "No scope named %s found"
(Marked.unmark id)
(** {1 Declarations pass} *)
(** Process a subscope declaration *)
@ -173,34 +240,31 @@ let process_subscope_decl
let name, name_pos = decl.scope_decl_context_scope_name in
let subscope, s_pos = decl.scope_decl_context_scope_sub_scope in
let scope_ctxt = ScopeMap.find scope ctxt.scopes in
match
Desugared.Ast.IdentMap.find_opt subscope scope_ctxt.sub_scopes_idmap
with
match Desugared.Ast.IdentMap.find_opt subscope scope_ctxt.var_idmap with
| Some use ->
let info =
match use with
| ScopeVar v -> ScopeVar.get_info v
| SubScope (ssc, _) -> SubScopeName.get_info ssc
in
Errors.raise_multispanned_error
[
Some "first use", Marked.get_mark (SubScopeName.get_info use);
Some "second use", s_pos;
]
[Some "first use", Marked.get_mark info; Some "second use", s_pos]
"Subscope name \"%a\" already used"
(Utils.Cli.format_with_style [ANSITerminal.yellow])
subscope
| None ->
let sub_scope_uid = SubScopeName.fresh (name, name_pos) in
let original_subscope_uid =
match Desugared.Ast.IdentMap.find_opt subscope ctxt.scope_idmap with
| None -> raise_unknown_identifier "for a scope" (subscope, s_pos)
| Some id -> id
get_scope ctxt decl.scope_decl_context_scope_sub_scope
in
let scope_ctxt =
{
scope_ctxt with
sub_scopes_idmap =
Desugared.Ast.IdentMap.add name sub_scope_uid
scope_ctxt.sub_scopes_idmap;
sub_scopes =
SubScopeMap.add sub_scope_uid original_subscope_uid
scope_ctxt.sub_scopes;
var_idmap =
Desugared.Ast.IdentMap.add name
(SubScope (sub_scope_uid, original_subscope_uid))
scope_ctxt.var_idmap;
sub_scopes = ScopeSet.add original_subscope_uid scope_ctxt.sub_scopes;
}
in
{ ctxt with scopes = ScopeMap.add scope scope_ctxt ctxt.scopes }
@ -232,16 +296,15 @@ let rec process_base_typ
| Ast.Boolean -> TLit TBool, typ_pos
| Ast.Text -> raise_unsupported_feature "text type" typ_pos
| Ast.Named ident -> (
match Desugared.Ast.IdentMap.find_opt ident ctxt.struct_idmap with
| Some s_uid -> TStruct s_uid, typ_pos
| None -> (
match Desugared.Ast.IdentMap.find_opt ident ctxt.enum_idmap with
| Some e_uid -> TEnum e_uid, typ_pos
| None ->
Errors.raise_spanned_error typ_pos
"Unknown type \"%a\", not a struct or enum previously declared"
(Utils.Cli.format_with_style [ANSITerminal.yellow])
ident)))
match Desugared.Ast.IdentMap.find_opt ident ctxt.typedefs with
| Some (TStruct s_uid) -> TStruct s_uid, typ_pos
| Some (TEnum e_uid) -> TEnum e_uid, typ_pos
| Some (TScope (_, s_uid)) -> TStruct s_uid, typ_pos
| None ->
Errors.raise_spanned_error typ_pos
"Unknown type \"%a\", not a struct or enum previously declared"
(Utils.Cli.format_with_style [ANSITerminal.yellow])
ident))
(** Process a type (function or not) *)
let process_type (ctxt : context) ((naked_typ, typ_pos) : Ast.typ) : typ =
@ -263,11 +326,13 @@ let process_data_decl
let scope_ctxt = ScopeMap.find scope ctxt.scopes in
match Desugared.Ast.IdentMap.find_opt name scope_ctxt.var_idmap with
| Some use ->
let info =
match use with
| ScopeVar v -> ScopeVar.get_info v
| SubScope (ssc, _) -> SubScopeName.get_info ssc
in
Errors.raise_multispanned_error
[
Some "First use:", Marked.get_mark (ScopeVar.get_info use);
Some "Second use:", pos;
]
[Some "First use:", Marked.get_mark info; Some "Second use:", pos]
"Variable name \"%a\" already used"
(Utils.Cli.format_with_style [ANSITerminal.yellow])
name
@ -276,7 +341,8 @@ let process_data_decl
let scope_ctxt =
{
scope_ctxt with
var_idmap = Desugared.Ast.IdentMap.add name uid scope_ctxt.var_idmap;
var_idmap =
Desugared.Ast.IdentMap.add name (ScopeVar uid) scope_ctxt.var_idmap;
}
in
let states_idmap, states_list =
@ -304,15 +370,6 @@ let process_data_decl
ctxt.var_typs;
}
(** Process an item declaration *)
let process_item_decl
(scope : ScopeName.t)
(ctxt : context)
(decl : Ast.scope_decl_context_item) : context =
match decl with
| Ast.ContextData data_decl -> process_data_decl scope ctxt data_decl
| Ast.ContextScope sub_decl -> process_subscope_decl scope ctxt sub_decl
(** Adds a binding to the context *)
let add_def_local_var (ctxt : context) (name : ident) :
context * Desugared.Ast.expr Var.t =
@ -326,20 +383,10 @@ let add_def_local_var (ctxt : context) (name : ident) :
in
ctxt, local_var_uid
(** Process a scope declaration *)
let process_scope_decl (ctxt : context) (decl : Ast.scope_decl) : context =
let name, _ = decl.scope_decl_name in
let scope_uid = Desugared.Ast.IdentMap.find name ctxt.scope_idmap in
List.fold_left
(fun ctxt item -> process_item_decl scope_uid ctxt (Marked.unmark item))
ctxt decl.scope_decl_context
(** Process a struct declaration *)
let process_struct_decl (ctxt : context) (sdecl : Ast.struct_decl) : context =
let s_uid =
Desugared.Ast.IdentMap.find (fst sdecl.struct_decl_name) ctxt.struct_idmap
in
if List.length sdecl.struct_decl_fields = 0 then
let s_uid = get_struct ctxt sdecl.struct_decl_name in
if sdecl.struct_decl_fields = [] then
Errors.raise_spanned_error
(Marked.get_mark sdecl.struct_decl_name)
"The struct %s does not have any fields; give it some for Catala to be \
@ -382,9 +429,7 @@ let process_struct_decl (ctxt : context) (sdecl : Ast.struct_decl) : context =
(** Process an enum declaration *)
let process_enum_decl (ctxt : context) (edecl : Ast.enum_decl) : context =
let e_uid =
Desugared.Ast.IdentMap.find (fst edecl.enum_decl_name) ctxt.enum_idmap
in
let e_uid = get_enum ctxt edecl.enum_decl_name in
if List.length edecl.enum_decl_cases = 0 then
Errors.raise_spanned_error
(Marked.get_mark edecl.enum_decl_name)
@ -424,6 +469,65 @@ let process_enum_decl (ctxt : context) (edecl : Ast.enum_decl) : context =
})
ctxt edecl.enum_decl_cases
(** Process an item declaration *)
let process_item_decl
(scope : ScopeName.t)
(ctxt : context)
(decl : Ast.scope_decl_context_item) : context =
match decl with
| Ast.ContextData data_decl -> process_data_decl scope ctxt data_decl
| Ast.ContextScope sub_decl -> process_subscope_decl scope ctxt sub_decl
(** Process a scope declaration *)
let process_scope_decl (ctxt : context) (decl : Ast.scope_decl) : context =
let scope_uid = get_scope ctxt decl.scope_decl_name in
let ctxt =
List.fold_left
(fun ctxt item -> process_item_decl scope_uid ctxt (Marked.unmark item))
ctxt decl.scope_decl_context
in
(* Add an implicit struct def for the scope output type *)
let output_fields =
List.fold_right
(fun item acc ->
match Marked.unmark item with
| Ast.ContextData
({
scope_decl_context_item_attribute =
{ scope_decl_context_io_output = true, _; _ };
_;
} as data) ->
Marked.mark (Marked.get_mark item)
{
Ast.struct_decl_field_name = data.scope_decl_context_item_name;
Ast.struct_decl_field_typ = data.scope_decl_context_item_typ;
}
:: acc
| _ -> acc)
decl.scope_decl_context []
in
if output_fields = [] then
(* we allow scopes without output variables, and still define their (empty)
output struct for convenience *)
{
ctxt with
structs =
StructMap.add
(get_struct ctxt decl.scope_decl_name)
StructFieldMap.empty ctxt.structs;
}
else
process_struct_decl ctxt
{
struct_decl_name = decl.scope_decl_name;
struct_decl_fields = output_fields;
}
let typedef_info = function
| TStruct t -> StructName.get_info t
| TEnum t -> EnumName.get_info t
| TScope (s, _) -> ScopeName.get_info s
(** Process the names of all declaration items *)
let process_name_item (ctxt : context) (item : Ast.code_item Marked.pos) :
context =
@ -438,56 +542,58 @@ let process_name_item (ctxt : context) (item : Ast.code_item Marked.pos) :
name
in
match Marked.unmark item with
| ScopeDecl decl -> (
| ScopeDecl decl ->
let name, pos = decl.scope_decl_name in
(* Checks if the name is already used *)
match Desugared.Ast.IdentMap.find_opt name ctxt.scope_idmap with
| Some use ->
raise_already_defined_error (ScopeName.get_info use) name pos "scope"
| None ->
let scope_uid = ScopeName.fresh (name, pos) in
{
ctxt with
scope_idmap = Desugared.Ast.IdentMap.add name scope_uid ctxt.scope_idmap;
scopes =
ScopeMap.add scope_uid
{
var_idmap = Desugared.Ast.IdentMap.empty;
scope_defs_contexts = Desugared.Ast.ScopeDefMap.empty;
sub_scopes_idmap = Desugared.Ast.IdentMap.empty;
sub_scopes = SubScopeMap.empty;
}
ctxt.scopes;
})
| StructDecl sdecl -> (
Option.iter
(fun use ->
raise_already_defined_error (typedef_info use) name pos "scope")
(Desugared.Ast.IdentMap.find_opt name ctxt.typedefs);
let scope_uid = ScopeName.fresh (name, pos) in
let out_struct_uid = StructName.fresh (name, pos) in
{
ctxt with
typedefs =
Desugared.Ast.IdentMap.add name
(TScope (scope_uid, out_struct_uid))
ctxt.typedefs;
scopes =
ScopeMap.add scope_uid
{
var_idmap = Desugared.Ast.IdentMap.empty;
scope_defs_contexts = Desugared.Ast.ScopeDefMap.empty;
sub_scopes = ScopeSet.empty;
}
ctxt.scopes;
}
| StructDecl sdecl ->
let name, pos = sdecl.struct_decl_name in
match Desugared.Ast.IdentMap.find_opt name ctxt.struct_idmap with
| Some use ->
raise_already_defined_error (StructName.get_info use) name pos "struct"
| None ->
let s_uid = StructName.fresh sdecl.struct_decl_name in
{
ctxt with
struct_idmap =
Desugared.Ast.IdentMap.add
(Marked.unmark sdecl.struct_decl_name)
s_uid ctxt.struct_idmap;
})
| EnumDecl edecl -> (
Option.iter
(fun use ->
raise_already_defined_error (typedef_info use) name pos "struct")
(Desugared.Ast.IdentMap.find_opt name ctxt.typedefs);
let s_uid = StructName.fresh sdecl.struct_decl_name in
{
ctxt with
typedefs =
Desugared.Ast.IdentMap.add
(Marked.unmark sdecl.struct_decl_name)
(TStruct s_uid) ctxt.typedefs;
}
| EnumDecl edecl ->
let name, pos = edecl.enum_decl_name in
match Desugared.Ast.IdentMap.find_opt name ctxt.enum_idmap with
| Some use ->
raise_already_defined_error (EnumName.get_info use) name pos "enum"
| None ->
let e_uid = EnumName.fresh edecl.enum_decl_name in
{
ctxt with
enum_idmap =
Desugared.Ast.IdentMap.add
(Marked.unmark edecl.enum_decl_name)
e_uid ctxt.enum_idmap;
})
Option.iter
(fun use ->
raise_already_defined_error (typedef_info use) name pos "enum")
(Desugared.Ast.IdentMap.find_opt name ctxt.typedefs);
let e_uid = EnumName.fresh edecl.enum_decl_name in
{
ctxt with
typedefs =
Desugared.Ast.IdentMap.add
(Marked.unmark edecl.enum_decl_name)
(TEnum e_uid) ctxt.typedefs;
}
| ScopeUse _ -> ctxt
(** Process a code item that is a declaration *)
@ -563,9 +669,12 @@ let get_def_key
ScopeVar.format_t x_uid
else None )
| [y; x] ->
let subscope_uid : SubScopeName.t = get_subscope_uid scope_uid ctxt y in
let subscope_real_uid : ScopeName.t =
SubScopeMap.find subscope_uid scope_ctxt.sub_scopes
let (subscope_uid, subscope_real_uid) : SubScopeName.t * ScopeName.t =
match
Desugared.Ast.IdentMap.find (Marked.unmark y) scope_ctxt.var_idmap
with
| SubScope (v, u) -> v, u
| _ -> invalid_arg "subscope_real_uid"
in
let x_uid = get_var_uid subscope_real_uid ctxt x in
Desugared.Ast.ScopeDef.SubScopeVar (subscope_uid, x_uid, pos)
@ -696,11 +805,13 @@ let process_scope_use_item
let process_scope_use (ctxt : context) (suse : Ast.scope_use) : context =
let s_name =
try
Desugared.Ast.IdentMap.find
match
Desugared.Ast.IdentMap.find_opt
(Marked.unmark suse.Ast.scope_use_name)
ctxt.scope_idmap
with Not_found ->
ctxt.typedefs
with
| Some (TScope (sn, _)) -> sn
| _ ->
Errors.raise_spanned_error
(Marked.get_mark suse.Ast.scope_use_name)
"\"%a\": this scope has not been declared anywhere, is it a typo?"
@ -722,14 +833,12 @@ let form_context (prgm : Ast.program) : context =
let empty_ctxt =
{
local_var_idmap = Desugared.Ast.IdentMap.empty;
scope_idmap = Desugared.Ast.IdentMap.empty;
typedefs = Desugared.Ast.IdentMap.empty;
scopes = ScopeMap.empty;
var_typs = ScopeVarMap.empty;
structs = StructMap.empty;
struct_idmap = Desugared.Ast.IdentMap.empty;
field_idmap = Desugared.Ast.IdentMap.empty;
enums = EnumMap.empty;
enum_idmap = Desugared.Ast.IdentMap.empty;
constructor_idmap = Desugared.Ast.IdentMap.empty;
}
in

41
compiler/surface/name_resolution.mli
View File

@ -34,14 +34,17 @@ type scope_def_context = {
label_idmap : Desugared.Ast.LabelName.t Desugared.Ast.IdentMap.t;
}
type scope_var_or_subscope =
| ScopeVar of ScopeVar.t
| SubScope of SubScopeName.t * ScopeName.t
type scope_context = {
var_idmap : ScopeVar.t Desugared.Ast.IdentMap.t; (** Scope variables *)
var_idmap : scope_var_or_subscope Desugared.Ast.IdentMap.t;
(** All variables, including scope variables and subscopes *)
scope_defs_contexts : scope_def_context Desugared.Ast.ScopeDefMap.t;
(** What is the default rule to refer to for unnamed exceptions, if any *)
sub_scopes_idmap : SubScopeName.t Desugared.Ast.IdentMap.t;
(** Sub-scopes variables *)
sub_scopes : ScopeName.t SubScopeMap.t;
(** To what scope sub-scopes refer to? *)
sub_scopes : ScopeSet.t;
(** Other scopes referred to by this scope. Used for dependency analysis *)
}
(** Inside a scope, we distinguish between the variables and the subscopes. *)
@ -59,19 +62,23 @@ type var_sig = {
var_sig_states_list : StateName.t list;
}
(** Capitalised type names share a namespace on the user side, but may
correspond to only one of the following *)
type typedef =
| TStruct of StructName.t
| TEnum of EnumName.t
| TScope of ScopeName.t * StructName.t
(** Implicitly defined output struct *)
type context = {
local_var_idmap : Desugared.Ast.expr Var.t Desugared.Ast.IdentMap.t;
(** Inside a definition, local variables can be introduced by functions
arguments or pattern matching *)
scope_idmap : ScopeName.t Desugared.Ast.IdentMap.t;
(** The names of the scopes *)
struct_idmap : StructName.t Desugared.Ast.IdentMap.t;
(** The names of the structs *)
typedefs : typedef Desugared.Ast.IdentMap.t;
(** Gathers the names of the scopes, structs and enums *)
field_idmap : StructFieldName.t StructMap.t Desugared.Ast.IdentMap.t;
(** The names of the struct fields. Names of fields can be shared between
different structs *)
enum_idmap : EnumName.t Desugared.Ast.IdentMap.t;
(** The names of the enums *)
constructor_idmap : EnumConstructor.t EnumMap.t Desugared.Ast.IdentMap.t;
(** The names of the enum constructors. Constructor names can be shared
between different enums *)
@ -131,6 +138,18 @@ val get_def_key :
Desugared.Ast.ScopeDef.t
(** Usage: [get_def_key var_name var_state scope_uid ctxt pos]*)
val get_enum : context -> ident Marked.pos -> EnumName.t
(** Find an enum definition from the typedefs, failing if there is none or it
has a different kind *)
val get_struct : context -> ident Marked.pos -> StructName.t
(** Find a struct definition from the typedefs (possibly an implicit output
struct from a scope), failing if there is none or it has a different kind *)
val get_scope : context -> ident Marked.pos -> ScopeName.t
(** Find a scope definition from the typedefs, failing if there is none or it
has a different kind *)
(** {1 API} *)
val form_context : Ast.program -> context

532
compiler/surface/parser.messages
View File

File diff suppressed because it is too large Load Diff

21
compiler/surface/parser.mly
View File

@ -79,6 +79,12 @@ small_expression:
| e = small_expression DOT c = option(terminated(constructor,DOT)) i = ident {
(Dotted (e, c, i), Pos.from_lpos $sloc)
}
| CARDINAL {
(Builtin Cardinal, Pos.from_lpos $sloc)
}
| LSQUARE l = separated_list(SEMICOLON, expression) RSQUARE {
(ArrayLit l, Pos.from_lpos $sloc)
}
struct_content_field:
| field = ident COLON e = logical_expression {
@ -89,7 +95,7 @@ enum_inject_content:
| CONTENT e = small_expression { e }
struct_inject_content:
| LBRACKET ALT fields = separated_nonempty_list(ALT, struct_content_field) RBRACKET { fields }
| LBRACKET fields = nonempty_list(preceded(ALT, struct_content_field)) RBRACKET { fields }
struct_or_enum_inject:
| enum = constructor c = option(preceded(DOT, constructor)) data = option(enum_inject_content) {
@ -103,15 +109,9 @@ struct_or_enum_inject:
primitive_expression:
| e = small_expression { e }
| CARDINAL {
(Builtin Cardinal, Pos.from_lpos $sloc)
}
| e = struct_or_enum_inject {
e
}
| LSQUARE l = separated_list(SEMICOLON, expression) RSQUARE {
(ArrayLit l, Pos.from_lpos $sloc)
}
num_literal:
| d = INT_LITERAL { (Int d, Pos.from_lpos $sloc) }
@ -199,9 +199,14 @@ aggregate:
base_expression:
| e = primitive_expression { e }
| ag = aggregate { ag }
| e1 = primitive_expression OF e2 = base_expression {
| e1 = small_expression OF e2 = base_expression {
(FunCall (e1, e2), Pos.from_lpos $sloc)
}
| c = constructor OF
LBRACKET fields = list(preceded (ALT, struct_content_field)) RBRACKET {
(* empty list is allowed *)
(ScopeCall (c, fields), Pos.from_lpos $sloc)
}
| e = primitive_expression WITH c = constructor_binding {
(TestMatchCase (e, (c, Pos.from_lpos $sloc)), Pos.from_lpos $sloc)
}

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

@ -127,6 +127,47 @@ let embed_collectivite (x: Collectivite.t) : runtime_value =
| Mayotte x -> ("Mayotte", embed_unit x))
module AllocationFamilialesAvril2008 = struct
type t = {age_minimum_alinea_1_l521_3: duration}
end
let embed_allocation_familiales_avril2008 (x: AllocationFamilialesAvril2008.t) : runtime_value =
Struct(["AllocationFamilialesAvril2008"],
[("âge_minimum_alinéa_1_l521_3", embed_duration
x.AllocationFamilialesAvril2008.age_minimum_alinea_1_l521_3)])
module AllocationsFamiliales = struct
type t = {montant_verse: money}
end
let embed_allocations_familiales (x: AllocationsFamiliales.t) : runtime_value =
Struct(["AllocationsFamiliales"],
[("montant_versé", embed_money x.AllocationsFamiliales.montant_verse)])
module Smic = struct
type t = {brut_horaire: money}
end
let embed_smic (x: Smic.t) : runtime_value = Struct(["Smic"],
[("brut_horaire", embed_money x.Smic.brut_horaire)])
module BaseMensuelleAllocationsFamiliales = struct
type t = {montant: money}
end
let embed_base_mensuelle_allocations_familiales (x: BaseMensuelleAllocationsFamiliales.t) : runtime_value =
Struct(["BaseMensuelleAllocationsFamiliales"],
[("montant", embed_money x.BaseMensuelleAllocationsFamiliales.montant)])
module InterfaceAllocationsFamiliales = struct
type t = {i_montant_verse: money}
end
let embed_interface_allocations_familiales (x: InterfaceAllocationsFamiliales.t) : runtime_value =
Struct(["InterfaceAllocationsFamiliales"],
[("i_montant_versé", embed_money
x.InterfaceAllocationsFamiliales.i_montant_verse)])
module EnfantEntree = struct
type t = {
d_identifiant: integer;
@ -181,24 +222,32 @@ let embed_enfant (x: Enfant.t) : runtime_value = Struct(["Enfant"],
x.Enfant.beneficie_titre_personnel_aide_personnelle_logement)])
module PrestationsFamilialesOut = struct
module EnfantLePlusAge = struct
type t = {le_plus_age: Enfant.t}
end
let embed_enfant_le_plus_age (x: EnfantLePlusAge.t) : runtime_value =
Struct(["EnfantLePlusÂgé"],
[("le_plus_âgé", embed_enfant x.EnfantLePlusAge.le_plus_age)])
module PrestationsFamiliales = struct
type t = {
droit_ouvert_out: Enfant.t -> bool;
conditions_hors_age_out: Enfant.t -> bool;
age_l512_3_2_out: duration;
regime_outre_mer_l751_1_out: bool
droit_ouvert: Enfant.t -> bool;
conditions_hors_age: Enfant.t -> bool;
age_l512_3_2: duration;
regime_outre_mer_l751_1: bool
}
end
let embed_prestations_familiales_out (x: PrestationsFamilialesOut.t) : runtime_value =
Struct(["PrestationsFamiliales_out"],
[("droit_ouvert_out", unembeddable
x.PrestationsFamilialesOut.droit_ouvert_out);
("conditions_hors_âge_out", unembeddable
x.PrestationsFamilialesOut.conditions_hors_age_out);
("âge_l512_3_2_out", embed_duration
x.PrestationsFamilialesOut.age_l512_3_2_out);
("régime_outre_mer_l751_1_out", embed_bool
x.PrestationsFamilialesOut.regime_outre_mer_l751_1_out)])
let embed_prestations_familiales (x: PrestationsFamiliales.t) : runtime_value =
Struct(["PrestationsFamiliales"],
[("droit_ouvert", unembeddable
x.PrestationsFamiliales.droit_ouvert);
("conditions_hors_âge", unembeddable
x.PrestationsFamiliales.conditions_hors_age);
("âge_l512_3_2", embed_duration
x.PrestationsFamiliales.age_l512_3_2);
("régime_outre_mer_l751_1", embed_bool
x.PrestationsFamiliales.regime_outre_mer_l751_1)])
module PrestationsFamilialesIn = struct
@ -218,29 +267,12 @@ let embed_prestations_familiales_in (x: PrestationsFamilialesIn.t) : runtime_val
x.PrestationsFamilialesIn.residence_in)])
module AllocationFamilialesAvril2008Out = struct
type t = {age_minimum_alinea_1_l521_3_out: duration}
end
let embed_allocation_familiales_avril2008_out (x: AllocationFamilialesAvril2008Out.t) : runtime_value =
Struct(["AllocationFamilialesAvril2008_out"],
[("âge_minimum_alinéa_1_l521_3_out", embed_duration
x.AllocationFamilialesAvril2008Out.age_minimum_alinea_1_l521_3_out)])
module AllocationFamilialesAvril2008In = struct
type t = unit
end
let embed_allocation_familiales_avril2008_in (_: AllocationFamilialesAvril2008In.t) : runtime_value = Unit
module EnfantLePlusAgeOut = struct
type t = {le_plus_age_out: Enfant.t}
end
let embed_enfant_le_plus_age_out (x: EnfantLePlusAgeOut.t) : runtime_value =
Struct(["EnfantLePlusÂgé_out"],
[("le_plus_âgé_out", embed_enfant x.EnfantLePlusAgeOut.le_plus_age_out)])
module EnfantLePlusAgeIn = struct
type t = {enfants_in: Enfant.t array}
end
@ -249,15 +281,6 @@ let embed_enfant_le_plus_age_in (x: EnfantLePlusAgeIn.t) : runtime_value =
[("enfants_in", embed_array (embed_enfant) x.EnfantLePlusAgeIn.enfants_in)])
module AllocationsFamilialesOut = struct
type t = {montant_verse_out: money}
end
let embed_allocations_familiales_out (x: AllocationsFamilialesOut.t) : runtime_value =
Struct(["AllocationsFamiliales_out"],
[("montant_versé_out", embed_money
x.AllocationsFamilialesOut.montant_verse_out)])
module AllocationsFamilialesIn = struct
type t = {
personne_charge_effective_permanente_est_parent_in: bool;
@ -287,13 +310,6 @@ let embed_allocations_familiales_in (x: AllocationsFamilialesIn.t) : runtime_val
x.AllocationsFamilialesIn.avait_enfant_a_charge_avant_1er_janvier_2012_in)])
module SmicOut = struct
type t = {brut_horaire_out: money}
end
let embed_smic_out (x: SmicOut.t) : runtime_value = Struct(["Smic_out"],
[("brut_horaire_out", embed_money x.SmicOut.brut_horaire_out)])
module SmicIn = struct
type t = {date_courante_in: date; residence_in: Collectivite.t}
end
@ -303,15 +319,6 @@ let embed_smic_in (x: SmicIn.t) : runtime_value = Struct(["Smic_in"],
("résidence_in", embed_collectivite x.SmicIn.residence_in)])
module BaseMensuelleAllocationsFamilialesOut = struct
type t = {montant_out: money}
end
let embed_base_mensuelle_allocations_familiales_out (x: BaseMensuelleAllocationsFamilialesOut.t) : runtime_value =
Struct(["BaseMensuelleAllocationsFamiliales_out"],
[("montant_out", embed_money
x.BaseMensuelleAllocationsFamilialesOut.montant_out)])
module BaseMensuelleAllocationsFamilialesIn = struct
type t = {date_courante_in: date}
end
@ -321,15 +328,6 @@ let embed_base_mensuelle_allocations_familiales_in (x: BaseMensuelleAllocationsF
x.BaseMensuelleAllocationsFamilialesIn.date_courante_in)])
module InterfaceAllocationsFamilialesOut = struct
type t = {i_montant_verse_out: money}
end
let embed_interface_allocations_familiales_out (x: InterfaceAllocationsFamilialesOut.t) : runtime_value =
Struct(["InterfaceAllocationsFamiliales_out"],
[("i_montant_versé_out", embed_money
x.InterfaceAllocationsFamilialesOut.i_montant_verse_out)])
module InterfaceAllocationsFamilialesIn = struct
type t = {
i_date_courante_in: date;
@ -361,7 +359,7 @@ let embed_interface_allocations_familiales_in (x: InterfaceAllocationsFamiliales
let allocation_familiales_avril2008 (allocation_familiales_avril2008_in: AllocationFamilialesAvril2008In.t) : AllocationFamilialesAvril2008Out.t =
let allocation_familiales_avril2008 (allocation_familiales_avril2008_in: AllocationFamilialesAvril2008In.t) : AllocationFamilialesAvril2008.t =
let age_minimum_alinea_1_l521_3_: duration = (log_variable_definition
["AllocationFamilialesAvril2008"; "âge_minimum_alinéa_1_l521_3"]
(embed_duration) (
@ -387,10 +385,10 @@ let allocation_familiales_avril2008 (allocation_familiales_avril2008_in: Allocat
start_line=76; start_column=10; end_line=76; end_column=37;
law_headings=["Allocations familiales"; "Champs d'applications";
"Prologue"]})))) in
{AllocationFamilialesAvril2008Out.age_minimum_alinea_1_l521_3_out =
{AllocationFamilialesAvril2008.age_minimum_alinea_1_l521_3 =
age_minimum_alinea_1_l521_3_}
let enfant_le_plus_age (enfant_le_plus_age_in: EnfantLePlusAgeIn.t) : EnfantLePlusAgeOut.t =
let enfant_le_plus_age (enfant_le_plus_age_in: EnfantLePlusAgeIn.t) : EnfantLePlusAge.t =
let enfants_: Enfant.t array = enfant_le_plus_age_in.EnfantLePlusAgeIn.enfants_in in
let le_plus_age_: Enfant.t = (log_variable_definition
["EnfantLePlusÂgé"; "le_plus_âgé"] (embed_enfant) (
@ -431,9 +429,9 @@ let enfant_le_plus_age (enfant_le_plus_age_in: EnfantLePlusAgeIn.t) : EnfantLePl
start_line=80; start_column=10; end_line=80; end_column=21;
law_headings=["Allocations familiales"; "Champs d'applications";
"Prologue"]})))) in
{EnfantLePlusAgeOut.le_plus_age_out = le_plus_age_}
{EnfantLePlusAge.le_plus_age = le_plus_age_}
let smic (smic_in: SmicIn.t) : SmicOut.t =
let smic (smic_in: SmicIn.t) : Smic.t =
let date_courante_: date = smic_in.SmicIn.date_courante_in in
let residence_: Collectivite.t = smic_in.SmicIn.residence_in in
let brut_horaire_: money = (log_variable_definition
@ -724,9 +722,9 @@ let smic (smic_in: SmicIn.t) : SmicOut.t =
{filename = "examples/allocations_familiales/../smic/smic.catala_fr";
start_line=11; start_column=10; end_line=11; end_column=22;
law_headings=["Prologue"; "Montant du salaire minimum de croissance"]})))) in
{SmicOut.brut_horaire_out = brut_horaire_}
{Smic.brut_horaire = brut_horaire_}
let base_mensuelle_allocations_familiales (base_mensuelle_allocations_familiales_in: BaseMensuelleAllocationsFamilialesIn.t) : BaseMensuelleAllocationsFamilialesOut.t =
let base_mensuelle_allocations_familiales (base_mensuelle_allocations_familiales_in: BaseMensuelleAllocationsFamilialesIn.t) : BaseMensuelleAllocationsFamiliales.t =
let date_courante_: date = base_mensuelle_allocations_familiales_in.BaseMensuelleAllocationsFamilialesIn.date_courante_in in
let montant_: money = (log_variable_definition
["BaseMensuelleAllocationsFamiliales"; "montant"] (embed_money) (
@ -801,9 +799,9 @@ let base_mensuelle_allocations_familiales (base_mensuelle_allocations_familiales
{filename = "examples/allocations_familiales/../base_mensuelle_allocations_familiales/bmaf.catala_fr";
start_line=6; start_column=10; end_line=6; end_column=17;
law_headings=["Montant de la base mensuelle des allocations familiales"]})))) in
{BaseMensuelleAllocationsFamilialesOut.montant_out = montant_}
{BaseMensuelleAllocationsFamiliales.montant = montant_}
let prestations_familiales (prestations_familiales_in: PrestationsFamilialesIn.t) : PrestationsFamilialesOut.t =
let prestations_familiales (prestations_familiales_in: PrestationsFamilialesIn.t) : PrestationsFamiliales.t =
let date_courante_: date = prestations_familiales_in.PrestationsFamilialesIn.date_courante_in in
let prestation_courante_: ElementPrestationsFamiliales.t = prestations_familiales_in.PrestationsFamilialesIn.prestation_courante_in in
let residence_: Collectivite.t = prestations_familiales_in.PrestationsFamilialesIn.residence_in in
@ -871,12 +869,12 @@ let prestations_familiales (prestations_familiales_in: PrestationsFamilialesIn.t
start_line=68; start_column=14; end_line=68; end_column=28;
law_headings=["Prestations familiales"; "Champs d'applications";
"Prologue"]})) in
let result_: SmicOut.t = (log_end_call
let result_: Smic.t = (log_end_call
["PrestationsFamiliales"; "smic"; "Smic"] ((log_begin_call
["PrestationsFamiliales"; "smic"; "Smic"] smic)
{SmicIn.date_courante_in = smic_dot_date_courante_;
SmicIn.residence_in = smic_dot_residence_})) in
let smic_dot_brut_horaire_: money = result_.SmicOut.brut_horaire_out in
let smic_dot_brut_horaire_: money = result_.Smic.brut_horaire in
let regime_outre_mer_l751_1_: bool = (log_variable_definition
["PrestationsFamiliales"; "régime_outre_mer_l751_1"] (embed_bool) (
try
@ -1185,13 +1183,12 @@ let prestations_familiales (prestations_familiales_in: PrestationsFamilialesIn.t
start_line=57; start_column=10; end_line=57; end_column=22;
law_headings=["Prestations familiales"; "Champs d'applications";
"Prologue"]})))) in
{PrestationsFamilialesOut.droit_ouvert_out = droit_ouvert_;
PrestationsFamilialesOut.conditions_hors_age_out = conditions_hors_age_;
PrestationsFamilialesOut.age_l512_3_2_out = age_l512_3_2_;
PrestationsFamilialesOut.regime_outre_mer_l751_1_out =
regime_outre_mer_l751_1_}
{PrestationsFamiliales.droit_ouvert = droit_ouvert_;
PrestationsFamiliales.conditions_hors_age = conditions_hors_age_;
PrestationsFamiliales.age_l512_3_2 = age_l512_3_2_;
PrestationsFamiliales.regime_outre_mer_l751_1 = regime_outre_mer_l751_1_}
let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t) : AllocationsFamilialesOut.t =
let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t) : AllocationsFamiliales.t =
let personne_charge_effective_permanente_est_parent_: bool = allocations_familiales_in.AllocationsFamilialesIn.personne_charge_effective_permanente_est_parent_in in
let personne_charge_effective_permanente_remplit_titre__i_: bool = allocations_familiales_in.AllocationsFamilialesIn.personne_charge_effective_permanente_remplit_titre_I_in in
let ressources_menage_: money = allocations_familiales_in.AllocationsFamilialesIn.ressources_menage_in in
@ -1612,13 +1609,13 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
start_line=147; start_column=11; end_line=147; end_column=41;
law_headings=["Allocations familiales"; "Champs d'applications";
"Prologue"]})))) in
let result_: AllocationFamilialesAvril2008Out.t = (log_end_call
let result_: AllocationFamilialesAvril2008.t = (log_end_call
["AllocationsFamiliales"; "version_avril_2008";
"AllocationFamilialesAvril2008"] ((log_begin_call
["AllocationsFamiliales"; "version_avril_2008";
"AllocationFamilialesAvril2008"] allocation_familiales_avril2008)
())) in
let version_avril_2008_dot_age_minimum_alinea_1_l521_3_: duration = result_.AllocationFamilialesAvril2008Out.age_minimum_alinea_1_l521_3_out in
let version_avril_2008_dot_age_minimum_alinea_1_l521_3_: duration = result_.AllocationFamilialesAvril2008.age_minimum_alinea_1_l521_3 in
let bmaf_dot_date_courante_: date =
try ((log_variable_definition
["AllocationsFamiliales"; "bmaf.date_courante"] (embed_date)
@ -1639,14 +1636,14 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
start_line=159; start_column=14; end_line=159; end_column=32;
law_headings=["Allocations familiales"; "Champs d'applications";
"Prologue"]})) in
let result_: BaseMensuelleAllocationsFamilialesOut.t = (log_end_call
let result_: BaseMensuelleAllocationsFamiliales.t = (log_end_call
["AllocationsFamiliales"; "bmaf"; "BaseMensuelleAllocationsFamiliales"]
((log_begin_call
["AllocationsFamiliales"; "bmaf"; "BaseMensuelleAllocationsFamiliales"]
base_mensuelle_allocations_familiales)
{BaseMensuelleAllocationsFamilialesIn.date_courante_in =
bmaf_dot_date_courante_})) in
let bmaf_dot_montant_: money = result_.BaseMensuelleAllocationsFamilialesOut.montant_out in
let bmaf_dot_montant_: money = result_.BaseMensuelleAllocationsFamiliales.montant in
let prestations_familiales_dot_date_courante_: date =
try ((log_variable_definition
["AllocationsFamiliales"; "prestations_familiales.date_courante"]
@ -1711,7 +1708,7 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
start_line=157; start_column=14; end_line=157; end_column=46;
law_headings=["Allocations familiales"; "Champs d'applications";
"Prologue"]})) in
let result_: PrestationsFamilialesOut.t = (log_end_call
let result_: PrestationsFamiliales.t = (log_end_call
["AllocationsFamiliales"; "prestations_familiales";
"PrestationsFamiliales"] ((log_begin_call
["AllocationsFamiliales"; "prestations_familiales";
@ -1722,10 +1719,10 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
prestations_familiales_dot_prestation_courante_;
PrestationsFamilialesIn.residence_in =
prestations_familiales_dot_residence_})) in
let prestations_familiales_dot_droit_ouvert_: Enfant.t -> bool = result_.PrestationsFamilialesOut.droit_ouvert_out in
let prestations_familiales_dot_conditions_hors_age_: Enfant.t -> bool = result_.PrestationsFamilialesOut.conditions_hors_age_out in
let prestations_familiales_dot_age_l512_3_2_: duration = result_.PrestationsFamilialesOut.age_l512_3_2_out in
let prestations_familiales_dot_regime_outre_mer_l751_1_: bool = result_.PrestationsFamilialesOut.regime_outre_mer_l751_1_out in
let prestations_familiales_dot_droit_ouvert_: Enfant.t -> bool = result_.PrestationsFamiliales.droit_ouvert in
let prestations_familiales_dot_conditions_hors_age_: Enfant.t -> bool = result_.PrestationsFamiliales.conditions_hors_age in
let prestations_familiales_dot_age_l512_3_2_: duration = result_.PrestationsFamiliales.age_l512_3_2 in
let prestations_familiales_dot_regime_outre_mer_l751_1_: bool = result_.PrestationsFamiliales.regime_outre_mer_l751_1 in
let enfant_le_plus_age_dot_enfants_: Enfant.t array =
try ((log_variable_definition
["AllocationsFamiliales"; "enfant_le_plus_âgé.enfants"]
@ -1744,13 +1741,13 @@ let allocations_familiales (allocations_familiales_in: AllocationsFamilialesIn.t
{filename = "examples/allocations_familiales/epilogue.catala_fr";
start_line=32; start_column=14; end_line=32; end_column=40;
law_headings=["Règles diverses"; "Épilogue"]})) in
let result_: EnfantLePlusAgeOut.t = (log_end_call
let result_: EnfantLePlusAge.t = (log_end_call
["AllocationsFamiliales"; "enfant_le_plus_âgé"; "EnfantLePlusÂgé"]
((log_begin_call
["AllocationsFamiliales"; "enfant_le_plus_âgé"; "EnfantLePlusÂgé"]
enfant_le_plus_age)
{EnfantLePlusAgeIn.enfants_in = enfant_le_plus_age_dot_enfants_})) in
let enfant_le_plus_age_dot_le_plus_age_: Enfant.t = result_.EnfantLePlusAgeOut.le_plus_age_out in
let enfant_le_plus_age_dot_le_plus_age_: Enfant.t = result_.EnfantLePlusAge.le_plus_age in
let age_minimum_alinea_1_l521_3_: Enfant.t -> duration = (log_variable_definition
["AllocationsFamiliales"; "âge_minimum_alinéa_1_l521_3"] (unembeddable)
(
@ -4889,9 +4886,9 @@ 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"]}) in
{AllocationsFamilialesOut.montant_verse_out = montant_verse_}
{AllocationsFamiliales.montant_verse = montant_verse_}
let interface_allocations_familiales (interface_allocations_familiales_in: InterfaceAllocationsFamilialesIn.t) : InterfaceAllocationsFamilialesOut.t =
let interface_allocations_familiales (interface_allocations_familiales_in: InterfaceAllocationsFamilialesIn.t) : InterfaceAllocationsFamiliales.t =
let i_date_courante_: date = interface_allocations_familiales_in.InterfaceAllocationsFamilialesIn.i_date_courante_in in
let i_enfants_: EnfantEntree.t array = interface_allocations_familiales_in.InterfaceAllocationsFamilialesIn.i_enfants_in in
let i_ressources_menage_: money = interface_allocations_familiales_in.InterfaceAllocationsFamilialesIn.i_ressources_menage_in in
@ -5113,7 +5110,7 @@ let interface_allocations_familiales (interface_allocations_familiales_in: Inter
{filename = "examples/allocations_familiales/epilogue.catala_fr";
start_line=99; start_column=5; end_line=99; end_column=72;
law_headings=["Interface du programme"; "Épilogue"]})) in
let result_: AllocationsFamilialesOut.t = (log_end_call
let result_: AllocationsFamiliales.t = (log_end_call
["InterfaceAllocationsFamiliales"; "allocations_familiales";
"AllocationsFamiliales"] ((log_begin_call
["InterfaceAllocationsFamiliales"; "allocations_familiales";
@ -5132,7 +5129,7 @@ let interface_allocations_familiales (interface_allocations_familiales_in: Inter
allocations_familiales_dot_enfants_a_charge_;
AllocationsFamilialesIn.avait_enfant_a_charge_avant_1er_janvier_2012_in =
allocations_familiales_dot_avait_enfant_a_charge_avant_1er_janvier_2012_})) in
let allocations_familiales_dot_montant_verse_: money = result_.AllocationsFamilialesOut.montant_verse_out in
let allocations_familiales_dot_montant_verse_: money = result_.AllocationsFamiliales.montant_verse in
let i_montant_verse_: money = (log_variable_definition
["InterfaceAllocationsFamiliales"; "i_montant_versé"] (embed_money) (
try
@ -5150,4 +5147,4 @@ let interface_allocations_familiales (interface_allocations_familiales_in: Inter
{filename = "examples/allocations_familiales/epilogue.catala_fr";
start_line=79; start_column=10; end_line=79; end_column=25;
law_headings=["Interface du programme"; "Épilogue"]})))) in
{InterfaceAllocationsFamilialesOut.i_montant_verse_out = i_montant_verse_}
{InterfaceAllocationsFamiliales.i_montant_verse = i_montant_verse_}

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

@ -337,6 +337,101 @@ let collectivite_of_jsoo (collectivite : collectivite Js.t)
"Unexpected '%s' kind for the enumeration 'Collectivite.t'" cons)
class type allocation_familiales_avril2008 =
object
method ageMinimumAlinea1L5213:
Runtime_jsoo.Runtime.duration Js.t Js.readonly_prop
end
let allocation_familiales_avril2008_to_jsoo
(allocation_familiales_avril2008 : AllocationFamilialesAvril2008.t)
: allocation_familiales_avril2008 Js.t =
object%js
val ageMinimumAlinea1L5213 =
duration_to_jsoo allocation_familiales_avril2008.age_minimum_alinea_1_l521_3
end
let allocation_familiales_avril2008_of_jsoo
(allocation_familiales_avril2008 : allocation_familiales_avril2008 Js.t) :
AllocationFamilialesAvril2008.t =
{
age_minimum_alinea_1_l521_3 =
duration_of_jsoo
allocation_familiales_avril2008##.ageMinimumAlinea1L5213
}
class type allocations_familiales =
object method montantVerse: Js.number Js.t Js.readonly_prop
end
let allocations_familiales_to_jsoo (allocations_familiales
: AllocationsFamiliales.t) : allocations_familiales Js.t =
object%js
val montantVerse =
Js.number_of_float @@ money_to_float allocations_familiales.montant_verse
end
let allocations_familiales_of_jsoo
(allocations_familiales : allocations_familiales Js.t) :
AllocationsFamiliales.t =
{
montant_verse =
money_of_decimal @@ decimal_of_float @@ Js.float_of_number
allocations_familiales##.montantVerse
}
class type smic =
object method brutHoraire: Js.number Js.t Js.readonly_prop
end
let smic_to_jsoo (smic : Smic.t) : smic Js.t =
object%js
val brutHoraire =
Js.number_of_float @@ money_to_float smic.brut_horaire
end
let smic_of_jsoo (smic : smic Js.t) : Smic.t =
{
brut_horaire =
money_of_decimal @@ decimal_of_float @@ Js.float_of_number
smic##.brutHoraire
}
class type base_mensuelle_allocations_familiales =
object method montant: Js.number Js.t Js.readonly_prop
end
let base_mensuelle_allocations_familiales_to_jsoo
(base_mensuelle_allocations_familiales
: BaseMensuelleAllocationsFamiliales.t)
: base_mensuelle_allocations_familiales Js.t =
object%js
val montant =
Js.number_of_float @@ money_to_float base_mensuelle_allocations_familiales.montant
end
let base_mensuelle_allocations_familiales_of_jsoo
(base_mensuelle_allocations_familiales
: base_mensuelle_allocations_familiales Js.t) :
BaseMensuelleAllocationsFamiliales.t =
{
montant =
money_of_decimal @@ decimal_of_float @@ Js.float_of_number
base_mensuelle_allocations_familiales##.montant
}
class type interface_allocations_familiales =
object method iMontantVerse: Js.number Js.t Js.readonly_prop
end
let interface_allocations_familiales_to_jsoo
(interface_allocations_familiales : InterfaceAllocationsFamiliales.t)
: interface_allocations_familiales Js.t =
object%js
val iMontantVerse =
Js.number_of_float @@ money_to_float interface_allocations_familiales.i_montant_verse
end
let interface_allocations_familiales_of_jsoo
(interface_allocations_familiales
: interface_allocations_familiales Js.t) :
InterfaceAllocationsFamiliales.t =
{
i_montant_verse =
money_of_decimal @@ decimal_of_float @@ Js.float_of_number
interface_allocations_familiales##.iMontantVerse
}
class type enfant_entree =
object
method dIdentifiant: int Js.readonly_prop
@ -422,40 +517,51 @@ class type enfant =
Js.to_bool enfant##.beneficieTitrePersonnelAidePersonnelleLogement
}
class type prestations_familiales_out =
object
method droitOuvertOut: (enfant Js.t, bool Js.t) Js.meth_callback Js.meth
method conditionsHorsAgeOut:
(enfant Js.t, bool Js.t) Js.meth_callback Js.meth
method ageL51232Out: Runtime_jsoo.Runtime.duration Js.t Js.readonly_prop
method regimeOutreMerL7511Out: bool Js.t Js.readonly_prop
class type enfant_le_plus_age =
object method lePlusAge: enfant Js.t Js.readonly_prop
end
let prestations_familiales_out_to_jsoo (prestations_familiales_out
: PrestationsFamilialesOut.t) : prestations_familiales_out Js.t =
let enfant_le_plus_age_to_jsoo (enfant_le_plus_age : EnfantLePlusAge.t)
: enfant_le_plus_age Js.t =
object%js
method droitOuvertOut = Js.wrap_meth_callback
(
fun input ->
Js.bool (prestations_familiales_out.droit_ouvert_out (enfant_of_jsoo input)))
method conditionsHorsAgeOut = Js.wrap_meth_callback
(
fun input ->
Js.bool (prestations_familiales_out.conditions_hors_age_out (enfant_of_jsoo input)))
val ageL51232Out =
duration_to_jsoo prestations_familiales_out.age_l512_3_2_out
val regimeOutreMerL7511Out =
Js.bool prestations_familiales_out.regime_outre_mer_l751_1_out
val lePlusAge = enfant_to_jsoo enfant_le_plus_age.le_plus_age
end
let prestations_familiales_out_of_jsoo
(prestations_familiales_out : prestations_familiales_out Js.t) :
PrestationsFamilialesOut.t =
let enfant_le_plus_age_of_jsoo
(enfant_le_plus_age : enfant_le_plus_age Js.t) : EnfantLePlusAge.t =
{le_plus_age = enfant_of_jsoo enfant_le_plus_age##.lePlusAge
}
class type prestations_familiales =
object
method droitOuvert: (enfant Js.t, bool Js.t) Js.meth_callback Js.meth
method conditionsHorsAge:
(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
let prestations_familiales_to_jsoo (prestations_familiales
: PrestationsFamiliales.t) : prestations_familiales Js.t =
object%js
method droitOuvert = Js.wrap_meth_callback
(
fun input ->
Js.bool (prestations_familiales.droit_ouvert (enfant_of_jsoo input)))
method conditionsHorsAge = Js.wrap_meth_callback
(
fun input ->
Js.bool (prestations_familiales.conditions_hors_age (enfant_of_jsoo input)))
val ageL51232 = duration_to_jsoo prestations_familiales.age_l512_3_2
val regimeOutreMerL7511 =
Js.bool prestations_familiales.regime_outre_mer_l751_1
end
let prestations_familiales_of_jsoo
(prestations_familiales : prestations_familiales Js.t) :
PrestationsFamiliales.t =
{
droit_ouvert_out = failwith "The function 'droit_ouvert_out' translation isn't yet supported...";
conditions_hors_age_out = failwith "The function 'conditions_hors_age_out' translation isn't yet supported...";
age_l512_3_2_out =
duration_of_jsoo prestations_familiales_out##.ageL51232Out;
regime_outre_mer_l751_1_out =
Js.to_bool prestations_familiales_out##.regimeOutreMerL7511Out
droit_ouvert = failwith "The function 'droit_ouvert' translation isn't yet supported...";
conditions_hors_age = failwith "The function 'conditions_hors_age' translation isn't yet supported...";
age_l512_3_2 = duration_of_jsoo prestations_familiales##.ageL51232;
regime_outre_mer_l751_1 =
Js.to_bool prestations_familiales##.regimeOutreMerL7511
}
class type prestations_familiales_in =
@ -488,48 +594,10 @@ class type prestations_familiales_in =
collectivite_of_jsoo prestations_familiales_in##.residenceIn
}
class type allocation_familiales_avril2008_out =
object
method ageMinimumAlinea1L5213Out:
Runtime_jsoo.Runtime.duration Js.t Js.readonly_prop
end
let allocation_familiales_avril2008_out_to_jsoo
(allocation_familiales_avril2008_out
: AllocationFamilialesAvril2008Out.t)
: allocation_familiales_avril2008_out Js.t =
object%js
val ageMinimumAlinea1L5213Out =
duration_to_jsoo allocation_familiales_avril2008_out.age_minimum_alinea_1_l521_3_out
end
let allocation_familiales_avril2008_out_of_jsoo
(allocation_familiales_avril2008_out
: allocation_familiales_avril2008_out Js.t) :
AllocationFamilialesAvril2008Out.t =
{
age_minimum_alinea_1_l521_3_out =
duration_of_jsoo
allocation_familiales_avril2008_out##.ageMinimumAlinea1L5213Out
}
class type allocation_familiales_avril2008_in =
object end
let allocation_familiales_avril2008_in_to_jsoo (_ : AllocationFamilialesAvril2008In.t) : allocation_familiales_avril2008_in Js.t = object%js end
let allocation_familiales_avril2008_in_of_jsoo (_ : allocation_familiales_avril2008_in Js.t) : AllocationFamilialesAvril2008In.t = ()
class type enfant_le_plus_age_out =
object method lePlusAgeOut: enfant Js.t Js.readonly_prop
end
let enfant_le_plus_age_out_to_jsoo (enfant_le_plus_age_out
: EnfantLePlusAgeOut.t) : enfant_le_plus_age_out Js.t =
object%js
val lePlusAgeOut =
enfant_to_jsoo enfant_le_plus_age_out.le_plus_age_out
end
let enfant_le_plus_age_out_of_jsoo
(enfant_le_plus_age_out : enfant_le_plus_age_out Js.t) :
EnfantLePlusAgeOut.t =
{le_plus_age_out = enfant_of_jsoo enfant_le_plus_age_out##.lePlusAgeOut
}
class type enfant_le_plus_age_in =
object method enfantsIn: enfant Js.t Js.js_array Js.t Js.readonly_prop
end
@ -548,24 +616,6 @@ class type enfant_le_plus_age_in =
enfant_le_plus_age_in##.enfantsIn
}
class type allocations_familiales_out =
object method montantVerseOut: Js.number Js.t Js.readonly_prop
end
let allocations_familiales_out_to_jsoo (allocations_familiales_out
: AllocationsFamilialesOut.t) : allocations_familiales_out Js.t =
object%js
val montantVerseOut =
Js.number_of_float @@ money_to_float allocations_familiales_out.montant_verse_out
end
let allocations_familiales_out_of_jsoo
(allocations_familiales_out : allocations_familiales_out Js.t) :
AllocationsFamilialesOut.t =
{
montant_verse_out =
money_of_decimal @@ decimal_of_float @@ Js.float_of_number
allocations_familiales_out##.montantVerseOut
}
class type allocations_familiales_in =
object
method personneChargeEffectivePermanenteEstParentIn:
@ -624,21 +674,6 @@ class type allocations_familiales_in =
allocations_familiales_in##.avaitEnfantAChargeAvant1erJanvier2012In
}
class type smic_out =
object method brutHoraireOut: Js.number Js.t Js.readonly_prop
end
let smic_out_to_jsoo (smic_out : SmicOut.t) : smic_out Js.t =
object%js
val brutHoraireOut =
Js.number_of_float @@ money_to_float smic_out.brut_horaire_out
end
let smic_out_of_jsoo (smic_out : smic_out Js.t) : SmicOut.t =
{
brut_horaire_out =
money_of_decimal @@ decimal_of_float @@ Js.float_of_number
smic_out##.brutHoraireOut
}
class type smic_in =
object
method dateCouranteIn: Js.js_string Js.t Js.readonly_prop
@ -655,27 +690,6 @@ class type smic_in =
residence_in = collectivite_of_jsoo smic_in##.residenceIn
}
class type base_mensuelle_allocations_familiales_out =
object method montantOut: Js.number Js.t Js.readonly_prop
end
let base_mensuelle_allocations_familiales_out_to_jsoo
(base_mensuelle_allocations_familiales_out
: BaseMensuelleAllocationsFamilialesOut.t)
: base_mensuelle_allocations_familiales_out Js.t =
object%js
val montantOut =
Js.number_of_float @@ money_to_float base_mensuelle_allocations_familiales_out.montant_out
end
let base_mensuelle_allocations_familiales_out_of_jsoo
(base_mensuelle_allocations_familiales_out
: base_mensuelle_allocations_familiales_out Js.t) :
BaseMensuelleAllocationsFamilialesOut.t =
{
montant_out =
money_of_decimal @@ decimal_of_float @@ Js.float_of_number
base_mensuelle_allocations_familiales_out##.montantOut
}
class type base_mensuelle_allocations_familiales_in =
object method dateCouranteIn: Js.js_string Js.t Js.readonly_prop
end
@ -697,27 +711,6 @@ class type base_mensuelle_allocations_familiales_in =
base_mensuelle_allocations_familiales_in##.dateCouranteIn
}
class type interface_allocations_familiales_out =
object method iMontantVerseOut: Js.number Js.t Js.readonly_prop
end
let interface_allocations_familiales_out_to_jsoo
(interface_allocations_familiales_out
: InterfaceAllocationsFamilialesOut.t)
: interface_allocations_familiales_out Js.t =
object%js
val iMontantVerseOut =
Js.number_of_float @@ money_to_float interface_allocations_familiales_out.i_montant_verse_out
end
let interface_allocations_familiales_out_of_jsoo
(interface_allocations_familiales_out
: interface_allocations_familiales_out Js.t) :
InterfaceAllocationsFamilialesOut.t =
{
i_montant_verse_out =
money_of_decimal @@ decimal_of_float @@ Js.float_of_number
interface_allocations_familiales_out##.iMontantVerseOut
}
class type interface_allocations_familiales_in =
object
method iDateCouranteIn: Js.js_string Js.t Js.readonly_prop
@ -786,85 +779,85 @@ class type interface_allocations_familiales_in =
let allocation_familiales_avril2008
(allocation_familiales_avril2008_in : allocation_familiales_avril2008_in Js.t)
: allocation_familiales_avril2008_out Js.t =
: allocation_familiales_avril2008 Js.t =
allocation_familiales_avril2008_in
|> allocation_familiales_avril2008_in_of_jsoo
|> allocation_familiales_avril2008
|> allocation_familiales_avril2008_out_to_jsoo
|> allocation_familiales_avril2008_to_jsoo
let enfant_le_plus_age (enfant_le_plus_age_in : enfant_le_plus_age_in Js.t)
: enfant_le_plus_age_out Js.t =
: enfant_le_plus_age Js.t =
enfant_le_plus_age_in
|> enfant_le_plus_age_in_of_jsoo
|> enfant_le_plus_age
|> enfant_le_plus_age_out_to_jsoo
|> enfant_le_plus_age_to_jsoo
let smic (smic_in : smic_in Js.t)
: smic_out Js.t =
smic_in |> smic_in_of_jsoo |> smic |> smic_out_to_jsoo
: smic Js.t =
smic_in |> smic_in_of_jsoo |> smic |> smic_to_jsoo
let base_mensuelle_allocations_familiales
(base_mensuelle_allocations_familiales_in : base_mensuelle_allocations_familiales_in Js.t)
: base_mensuelle_allocations_familiales_out Js.t =
: base_mensuelle_allocations_familiales Js.t =
base_mensuelle_allocations_familiales_in
|> base_mensuelle_allocations_familiales_in_of_jsoo
|> base_mensuelle_allocations_familiales
|> base_mensuelle_allocations_familiales_out_to_jsoo
|> base_mensuelle_allocations_familiales_to_jsoo
let prestations_familiales
(prestations_familiales_in : prestations_familiales_in Js.t)
: prestations_familiales_out Js.t =
: prestations_familiales Js.t =
prestations_familiales_in
|> prestations_familiales_in_of_jsoo
|> prestations_familiales
|> prestations_familiales_out_to_jsoo
|> prestations_familiales_to_jsoo
let allocations_familiales
(allocations_familiales_in : allocations_familiales_in Js.t)
: allocations_familiales_out Js.t =
: allocations_familiales Js.t =
allocations_familiales_in
|> allocations_familiales_in_of_jsoo
|> allocations_familiales
|> allocations_familiales_out_to_jsoo
|> allocations_familiales_to_jsoo
let interface_allocations_familiales
(interface_allocations_familiales_in : interface_allocations_familiales_in Js.t)
: interface_allocations_familiales_out Js.t =
: interface_allocations_familiales Js.t =
interface_allocations_familiales_in
|> interface_allocations_familiales_in_of_jsoo
|> interface_allocations_familiales
|> interface_allocations_familiales_out_to_jsoo
|> interface_allocations_familiales_to_jsoo
let _ =
Js.export "AllocationsFamilialesLib"
(object%js
method allocationFamilialesAvril2008 : (allocation_familiales_avril2008_in Js.t -> allocation_familiales_avril2008_out Js.t) Js.callback =
method allocationFamilialesAvril2008 : (allocation_familiales_avril2008_in Js.t -> allocation_familiales_avril2008 Js.t) Js.callback =
Js.wrap_callback allocation_familiales_avril2008
method enfantLePlusAge : (enfant_le_plus_age_in Js.t -> enfant_le_plus_age_out Js.t) Js.callback =
method enfantLePlusAge : (enfant_le_plus_age_in Js.t -> enfant_le_plus_age Js.t) Js.callback =
Js.wrap_callback enfant_le_plus_age
method smic : (smic_in Js.t -> smic_out Js.t) Js.callback =
method smic : (smic_in Js.t -> smic Js.t) Js.callback =
Js.wrap_callback smic
method baseMensuelleAllocationsFamiliales : (base_mensuelle_allocations_familiales_in Js.t -> base_mensuelle_allocations_familiales_out Js.t) Js.callback =
method baseMensuelleAllocationsFamiliales : (base_mensuelle_allocations_familiales_in Js.t -> base_mensuelle_allocations_familiales Js.t) Js.callback =
Js.wrap_callback base_mensuelle_allocations_familiales
method prestationsFamiliales : (prestations_familiales_in Js.t -> prestations_familiales_out Js.t) Js.callback =
method prestationsFamiliales : (prestations_familiales_in Js.t -> prestations_familiales Js.t) Js.callback =
Js.wrap_callback prestations_familiales
method allocationsFamiliales : (allocations_familiales_in Js.t -> allocations_familiales_out Js.t) Js.callback =
method allocationsFamiliales : (allocations_familiales_in Js.t -> allocations_familiales Js.t) Js.callback =
Js.wrap_callback allocations_familiales
method interfaceAllocationsFamiliales : (interface_allocations_familiales_in Js.t -> interface_allocations_familiales_out Js.t) Js.callback =
method interfaceAllocationsFamiliales : (interface_allocations_familiales_in Js.t -> interface_allocations_familiales Js.t) Js.callback =
Js.wrap_callback interface_allocations_familiales
end)

9
tests/test_bool/good/test_bool.catala_en
View File

@ -15,7 +15,7 @@ scope TestBool:
$ catala Dcalc
let TestBool :
TestBool_in{"foo_in": unit → bool; "bar_in": unit → integer} →
TestBool_out{"foo_out": bool; "bar_out": integer} =
TestBool{"foo": bool; "bar": integer} =
λ (TestBool_in: TestBool_in{"foo_in": unit → bool; "bar_in":
unit → integer}) →
let foo : unit → bool = TestBool_in."foo_in" in
@ -26,7 +26,7 @@ let TestBool :
⟨foo () | true ⊢
⟨⟨bar1 >= 0 ⊢ true⟩, ⟨bar1 < 0 ⊢ false⟩ | false ⊢
∅ ⟩⟩ in
TestBool_out {"foo_out"= foo1; "bar_out"= bar1} in
TestBool {"foo"= foo1; "bar"= bar1} in
TestBool
```
@ -39,6 +39,11 @@ $ catala Interpret -s TestBool
```catala-test-inline
$ catala Scopelang
type TestBool = {
foo: bool
bar: integer
}
let scope TestBool (foo: bool|context|output) (bar: integer|context|output) =
let bar : integer = reentrant or by default ⟨true ⊢ 1⟩;
let foo : bool = reentrant or by default

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

@ -33,6 +33,10 @@ scope Foo:
```catala-test-inline
$ catala Scopelang
type Foo = {
x: integer
}
let scope Foo (y: integer|input) (x: integer|internal|output) =
let x : integer =
⟨⟨⟨⟨y = 4 ⊢ 4⟩, ⟨y = 5 ⊢ 5⟩ | false ⊢ ∅ ⟩ | true

2
tests/test_io/good/all_io.catala_en
View File

@ -32,7 +32,7 @@ let A =
⟨e () | true ⊢ ⟨true ⊢ b + c + d + 1⟩⟩ in
let f1 : integer = error_empty
⟨f () | true ⊢ ⟨true ⊢ e1 + 1⟩⟩ in
A_out {"b_out"= b; "d_out"= d; "f_out"= f1}
A {"b"= b; "d"= d; "f"= f1}
```
```catala-test-inline

6
tests/test_io/good/condition_only_input.catala_en
View File

@ -19,10 +19,10 @@ $ catala Dcalc -s B
let B =
λ (B_in: B_in{}) →
let a.x : bool = error_empty ⟨true ⊢ false⟩ in
let result : A_out{"y_out": integer} = A (A_in {"x_in"= a.x}) in
let a.y : integer = result."y_out" in
let result : A{"y": integer} = A (A_in {"x_in"= a.x}) in
let a.y : integer = result."y" in
let _ : unit = assert (error_empty a.y = 1) in
B_out {}
B {}
```
```catala-test-inline

7
tests/test_io/good/subscope.catala_en
View File

@ -26,11 +26,10 @@ let B =
λ (B_in: B_in{}) →
let a.a : unit → integer = λ (_: unit) → ∅ in
let a.b : integer = error_empty ⟨true ⊢ 2⟩ in
let result : A_out{"c_out": integer} =
A (A_in {"a_in"= a.a; "b_in"= a.b}) in
let a.c : integer = result."c_out" in
let result : A{"c": integer} = A (A_in {"a_in"= a.a; "b_in"= a.b}) in
let a.c : integer = result."c" in
let _ : unit = assert (error_empty a.c = 1) in
B_out {}
B {}
```
```catala-test-inline

22
tests/test_scope/good/191_fix_record_name_confusion.catala_en
View File

@ -23,25 +23,25 @@ open Runtime_ocaml.Runtime
[@@@ocaml.warning "-4-26-27-32-41-42"]
module ScopeAOut = struct
type t = {a_out: bool}
module ScopeA = struct
type t = {a: bool}
end
module ScopeB = struct
type t = unit
end
module ScopeAIn = struct
type t = {a_in: unit -> bool}
end
module ScopeBOut = struct
type t = unit
end
module ScopeBIn = struct
type t = {a_in: unit -> bool}
end
let scope_a (scope_a_in: ScopeAIn.t) : ScopeAOut.t =
let scope_a (scope_a_in: ScopeAIn.t) : ScopeA.t =
let a_: unit -> bool = scope_a_in.ScopeAIn.a_in in
let a_: bool = (
try
@ -61,13 +61,13 @@ let scope_a (scope_a_in: ScopeAIn.t) : ScopeAOut.t =
{filename = "tests/test_scope/good/191_fix_record_name_confusion.catala_en";
start_line=5; start_column=18; end_line=5; end_column=19;
law_headings=["Article"]}))) in
{ScopeAOut.a_out = a_}
{ScopeA.a = a_}
let scope_b (scope_b_in: ScopeBIn.t) : ScopeBOut.t =
let scope_b (scope_b_in: ScopeBIn.t) : ScopeB.t =
let a_: unit -> bool = scope_b_in.ScopeBIn.a_in in
let scope_a_dot_a_: unit -> bool = fun (_: unit) -> (raise EmptyError) in
let result_: ScopeAOut.t = ((scope_a) {ScopeAIn.a_in = scope_a_dot_a_}) in
let scope_a_dot_a_: bool = result_.ScopeAOut.a_out in
let result_: ScopeA.t = ((scope_a) {ScopeAIn.a_in = scope_a_dot_a_}) in
let scope_a_dot_a_: bool = result_.ScopeA.a in
let a_: bool = (
try
(handle_default

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

@ -13,5 +13,5 @@ let Foo2 (Foo2_in : Foo2_in{}) =
raise NoValueProvided;
decl bar : integer;
bar = temp_bar_4;
return Foo2_out {"bar_out": bar_3}
return Foo2 {"bar": bar_3}
```

31
tests/test_scope/good/scope_call.catala_en Normal file
View File

@ -0,0 +1,31 @@
```catala
declaration structure Test:
data z2 content integer
data z3 content integer
declaration scope SubFoo:
input x content integer
input y content integer
output z1 content integer
output z2 content integer
declaration scope Foo:
output example content integer
scope SubFoo:
definition z1 equals x + y
definition z2 equals x - y
scope Foo:
definition example equals
if true or false then
let results_foo equals SubFoo of { -- x: 1 -- y: 2 } in
results_foo.z1 + 1 * (SubFoo of { -- x: 10 -- y: 20 }).SubFoo.z2
else 0
```
```catala-test-inline
$ catala interpret -s Foo
[RESULT] Computation successful! Results:
[RESULT] example = -7
```

2
tests/test_scope/good/simple.catala_en
View File

@ -15,5 +15,5 @@ let Foo =
let bar : integer =
try handle_default [] (λ (_: unit) → true) (λ (_: unit) → 0) with
EmptyError -> raise NoValueProvided in
Foo_out {"bar_out"= bar}
Foo {"bar"= bar}
```

2
tests/test_struct/bad/nonexisting_struct.catala_en
View File

@ -15,7 +15,7 @@ scope A:
```catala-test-inline
$ catala Interpret -s A
[ERROR] Struct Fo has not been defined before
[ERROR] No struct named Fo found
--> tests/test_struct/bad/nonexisting_struct.catala_en
|

2
tests/test_variable_state/good/simple.catala_en
View File

@ -18,7 +18,7 @@ scope A:
```catala-test-inline
$ catala Interpret -s A
[RESULT] Computation successful! Results:
[RESULT] foo_fizz = 3
[RESULT] foo = 3
```
```catala-test-inline

2
tests/test_variable_state/good/subscope.catala_en
View File

@ -42,6 +42,6 @@ let scope A (foo_bar: integer|context) (foo_baz: integer|internal)
```catala-test-inline
$ catala Interpret -s B
[RESULT] Computation successful! Results:
[RESULT] foofoo_baz = 4
[RESULT] foofoo = 4
[RESULT] foofoofoo = 6
```