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

Simple struct test passing

Browse Source
This commit is contained in:
Denis Merigoux 2020-12-05 17:27:08 +01:00
parent ef5dd18bc7
commit 70aa8ae2c1
10 changed files with 115 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/catala/catala_surface/ast.ml
View File

@ -109,6 +109,7 @@ and expression =
| Literal of literal
| EnumInject of constructor Pos.marked * expression Pos.marked option
| EnumProject of expression Pos.marked * constructor Pos.marked
| StructLit of constructor Pos.marked * (ident Pos.marked * expression Pos.marked) list
| Ident of ident
| Dotted of expression Pos.marked * ident Pos.marked
(* Dotted is for both struct field projection and sub-scope variables *)

59
src/catala/catala_surface/desugaring.ml
View File

@ -36,6 +36,8 @@ let translate_binop (op : Ast.binop) : Dcalc.Ast.binop =
let translate_unop (op : Ast.unop) : Dcalc.Ast.unop = match op with Not -> Not | Minus -> Minus
module LiftStructFieldMap = Bindlib.Lift (Scopelang.Ast.StructFieldMap)
let rec translate_expr (scope : Scopelang.Ast.ScopeName.t)
(def_key : Desugared.Ast.ScopeDef.t option) (ctxt : Name_resolution.context)
((expr, pos) : Ast.expression Pos.marked) : Scopelang.Ast.expr Pos.marked Bindlib.box =
@ -87,9 +89,9 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t)
| None -> Name_resolution.raise_unknown_identifier "for a scope-wide variable" (x, pos) )
)
| Dotted (e, x) -> (
(* For now we only accept dotted identifiers of the type y.x where y is a sub-scope *)
match Pos.unmark e with
| Ident y ->
| Ident y when Name_resolution.is_subscope_uid scope ctxt y ->
(* In this case, y.x is a subscope variable *)
let subscope_uid : Scopelang.Ast.SubScopeName.t =
Name_resolution.get_subscope_uid scope ctxt (Pos.same_pos_as y e)
in
@ -102,13 +104,60 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t)
(SubScopeVar (subscope_real_uid, (subscope_uid, pos), (subscope_var_uid, pos))),
pos )
| _ ->
Name_resolution.raise_unsupported_feature
"left hand side of a dotted expression should be an\n\n identifier" pos )
(* In this case e.x is the struct field x access of expression e *)
let e = translate_expr scope def_key ctxt e in
let x_possible_structs =
try Desugared.Ast.IdentMap.find (Pos.unmark x) ctxt.field_idmap
with Not_found ->
Errors.raise_spanned_error "This identifier should refer to a struct field"
(Pos.get_position x)
in
if Scopelang.Ast.StructMap.cardinal x_possible_structs > 1 then
Errors.raise_spanned_error
(Format.asprintf
"This struct field name is ambiguous, it can belong to %a. Desambiguate it by \
prefixing it with the struct name."
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt " or ")
(fun fmt (s_name, _) ->
Format.fprintf fmt "%a" Scopelang.Ast.StructName.format_t s_name))
(Scopelang.Ast.StructMap.bindings x_possible_structs))
(Pos.get_position x)
else
let s_uid, f_uid = Scopelang.Ast.StructMap.choose x_possible_structs in
Bindlib.box_apply (fun e -> (Scopelang.Ast.EStructAccess (e, f_uid, s_uid), pos)) e )
| FunCall (f, arg) ->
Bindlib.box_apply2
(fun f arg -> (Scopelang.Ast.EApp (f, [ arg ]), pos))
(rec_helper f) (rec_helper arg)
| _ -> Name_resolution.raise_unsupported_feature "unsupported expression" pos
| StructLit (s_name, fields) ->
let s_uid =
try Desugared.Ast.IdentMap.find (Pos.unmark s_name) ctxt.struct_idmap
with Not_found ->
Errors.raise_spanned_error "This identifier should refer to a struct name"
(Pos.get_position s_name)
in
let s_fields =
List.fold_left
(fun s_fields (f_name, f_e) ->
let f_uid =
try
Scopelang.Ast.StructMap.find s_uid
(Desugared.Ast.IdentMap.find (Pos.unmark f_name) ctxt.field_idmap)
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf "This identifier should refer to a field of struct %s"
(Pos.unmark s_name))
(Pos.get_position f_name)
in
let f_e = translate_expr scope def_key ctxt f_e in
Scopelang.Ast.StructFieldMap.add f_uid f_e s_fields)
Scopelang.Ast.StructFieldMap.empty fields
in
Bindlib.box_apply
(fun s_fields -> (Scopelang.Ast.EStruct (s_uid, s_fields), pos))
(LiftStructFieldMap.lift_box s_fields)
| _ -> Name_resolution.raise_unsupported_feature "desugaring not implemented" pos
(* Translation from the parsed ast to the scope language *)

8
src/catala/catala_surface/lexer.ml
View File

@ -38,6 +38,8 @@ let token_list_language_agnostic : (string * token) list =
("=", EQUAL);
("(", LPAREN);
(")", RPAREN);
("{", LBRACKET);
("}", RBRACKET);
("+", PLUS);
("-", MINUS);
("*", MULT);
@ -322,6 +324,12 @@ let rec lex_code (lexbuf : lexbuf) : token =
| ')' ->
update_acc lexbuf;
RPAREN
| '{' ->
update_acc lexbuf;
LBRACKET
| '}' ->
update_acc lexbuf;
RBRACKET
| '+' ->
update_acc lexbuf;
PLUS

6
src/catala/catala_surface/lexer_en.ml
View File

@ -294,6 +294,12 @@ let rec lex_code_en (lexbuf : lexbuf) : token =
| ')' ->
L.update_acc lexbuf;
RPAREN
| '{' ->
L.update_acc lexbuf;
LBRACKET
| '}' ->
L.update_acc lexbuf;
RBRACKET
| '+' ->
L.update_acc lexbuf;
PLUS

6
src/catala/catala_surface/lexer_fr.ml
View File

@ -303,6 +303,12 @@ let rec lex_code_fr (lexbuf : lexbuf) : token =
| ')' ->
L.update_acc lexbuf;
RPAREN
| '{' ->
L.update_acc lexbuf;
LBRACKET
| '}' ->
L.update_acc lexbuf;
RBRACKET
| '+' ->
L.update_acc lexbuf;
PLUS

16
src/catala/catala_surface/name_resolution.ml
View File

@ -53,7 +53,7 @@ type context = {
}
let raise_unsupported_feature (msg : string) (pos : Pos.t) =
Errors.raise_spanned_error (Printf.sprintf "unsupported feature: %s" msg) pos
Errors.raise_spanned_error (Printf.sprintf "Unsupported feature: %s" msg) pos
let raise_unknown_identifier (msg : string) (ident : ident Pos.marked) =
Errors.raise_spanned_error
@ -72,7 +72,7 @@ let process_subscope_decl (scope : Scopelang.Ast.ScopeName.t) (ctxt : context)
let scope_ctxt = Scopelang.Ast.ScopeMap.find scope ctxt.scopes in
match Desugared.Ast.IdentMap.find_opt subscope scope_ctxt.sub_scopes_idmap with
| Some use ->
Errors.raise_multispanned_error "subscope name already used"
Errors.raise_multispanned_error "Subscope name already used"
[
(Some "first use", Pos.get_position (Scopelang.Ast.SubScopeName.get_info use));
(Some "second use", s_pos);
@ -221,8 +221,12 @@ let qident_to_scope_def (ctxt : context) (scope_uid : Scopelang.Ast.ScopeName.t)
match Desugared.Ast.IdentMap.find_opt (Pos.unmark x) sub_scope_ctx.var_idmap with
| None -> raise_unknown_identifier "for a var of this subscope" x
| Some id -> Desugared.Ast.ScopeDef.SubScopeVar (sub_scope_uid, id) )
| [ s; _ ] -> raise_unsupported_feature "not a subscope" (Pos.get_position s)
| _ -> raise_unsupported_feature "wrong qident" (Pos.get_position id)
| [ s; _ ] ->
Errors.raise_spanned_error "This identifier should refer to a subscope, but does not"
(Pos.get_position s)
| _ ->
Errors.raise_spanned_error "Only scope vars or subscope vars can be defined"
(Pos.get_position id)
let process_scope_use (ctxt : context) (use : Ast.scope_use) : context =
let scope_uid =
@ -414,6 +418,10 @@ let get_subscope_uid (scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : context)
| None -> raise_unknown_identifier "for a subscope of this scope" (y, pos)
| Some sub_uid -> sub_uid
let is_subscope_uid (scope_uid : Scopelang.Ast.ScopeName.t) (ctxt : context) (y : ident) : bool =
let scope = Scopelang.Ast.ScopeMap.find scope_uid ctxt.scopes in
Desugared.Ast.IdentMap.mem y scope.sub_scopes_idmap
(** Checks if the var_uid belongs to the scope scope_uid *)
let belongs_to (ctxt : context) (uid : Scopelang.Ast.ScopeVar.t)
(scope_uid : Scopelang.Ast.ScopeName.t) : bool =

6
src/catala/catala_surface/parser.mly
View File

@ -53,7 +53,7 @@
%token STRUCT CONTENT IF THEN DEPENDS DECLARATION
%token CONTEXT ENUM ELSE DATE SUM
%token BEGIN_METADATA END_METADATA MONEY DECIMAL
%token UNDER_CONDITION CONSEQUENCE
%token UNDER_CONDITION CONSEQUENCE LBRACKET RBRACKET
%type <Ast.source_file_or_master> source_file_or_master
@ -120,7 +120,7 @@ enum_inject_content:
struct_or_enum_inject_content:
| e = option(enum_inject_content) { EnumContent e }
| CONTENT LPAREN ALT fields = separated_nonempty_list(ALT, struct_content_field) RPAREN {
| LBRACKET ALT fields = separated_nonempty_list(ALT, struct_content_field) RBRACKET {
StructContent fields
}
@ -129,7 +129,7 @@ struct_or_enum_inject:
match data with
| EnumContent data ->
(EnumInject (c, data), $sloc)
| _ -> assert false (* should not happen *)
| StructContent fields -> (StructLit (c, fields), $sloc)
}
primitive_expression:

40
src/catala/scope_language/scope_to_dcalc.ml
View File

@ -87,14 +87,12 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Po
List.fold_right
(fun (field_name, _) (d_fields, e_fields) ->
let field_e =
Option.value
~default:
(Errors.raise_spanned_error
(Format.asprintf "The field %a does not belong to the structure %a"
Ast.StructFieldName.format_t field_name Ast.StructName.format_t
struct_name)
(Pos.get_position e))
(Ast.StructFieldMap.find_opt field_name e_fields)
try Ast.StructFieldMap.find field_name e_fields
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf "The field %a does not belong to the structure %a"
Ast.StructFieldName.format_t field_name Ast.StructName.format_t struct_name)
(Pos.get_position e)
in
let field_d = translate_expr ctx field_e in
(field_d :: d_fields, Ast.StructFieldMap.remove field_name e_fields))
@ -115,26 +113,24 @@ let rec translate_expr (ctx : ctx) (e : Ast.expr Pos.marked) : Dcalc.Ast.expr Po
| EStructAccess (e1, field_name, struct_name) ->
let struct_sig = Ast.StructMap.find struct_name ctx.structs in
let _, field_index =
Option.value
~default:
(Errors.raise_spanned_error
(Format.asprintf "The field %a does not belong to the structure %a"
Ast.StructFieldName.format_t field_name Ast.StructName.format_t struct_name)
(Pos.get_position e))
(List.assoc_opt field_name (List.mapi (fun i (x, y) -> (x, (y, i))) struct_sig))
try List.assoc field_name (List.mapi (fun i (x, y) -> (x, (y, i))) struct_sig)
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf "The field %a does not belong to the structure %a"
Ast.StructFieldName.format_t field_name Ast.StructName.format_t struct_name)
(Pos.get_position e)
in
let e1 = translate_expr ctx e1 in
Bindlib.box_apply (fun e1 -> Dcalc.Ast.ETupleAccess (e1, field_index)) e1
| EEnumInj (e1, constructor, enum_name) ->
let enum_sig = Ast.EnumMap.find enum_name ctx.enums in
let _, constructor_index =
Option.value
~default:
(Errors.raise_spanned_error
(Format.asprintf "The constructor %a does not belong to the enum %a"
Ast.EnumConstructor.format_t constructor Ast.EnumName.format_t enum_name)
(Pos.get_position e))
(List.assoc_opt constructor (List.mapi (fun i (x, y) -> (x, (y, i))) enum_sig))
try List.assoc constructor (List.mapi (fun i (x, y) -> (x, (y, i))) enum_sig)
with Not_found ->
Errors.raise_spanned_error
(Format.asprintf "The constructor %a does not belong to the enum %a"
Ast.EnumConstructor.format_t constructor Ast.EnumName.format_t enum_name)
(Pos.get_position e)
in
let e1 = translate_expr ctx e1 in
Bindlib.box_apply

4
tests/Makefile
View File

@ -2,7 +2,9 @@
# Preamble
############################################
CATALA=dune exec --no-print-director ../src/catala.exe -- Interpret
CATALA_OPTS?=
CATALA=dune exec --no-print-director ../src/catala.exe -- Interpret $(CATALA_OPTS)
tests: $(wildcard */*.catala)

6
tests/test_struct/simple.catala
View File

@ -10,7 +10,9 @@ new scope A:
param z type int
scope A:
def s.x := 1
def s.y := 2
def s := S {
-- x : 1
-- y : 2
}
def z := s.x + s.y
*/