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

Added map visitors to surface AST

Browse Source
This commit is contained in:
Denis Merigoux 2021-01-20 16:06:04 +01:00
parent 4d7cea397a
commit a9d415b7b9
8 changed files with 247 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Makefile
View File

@ -13,7 +13,8 @@ dependencies-ocaml:
opam install \
ocamlformat ANSITerminal sedlex menhir menhirLib dune cmdliner obelisk \
re obelisk unionfind bindlib zarith zarith_stubs_js ocamlgraph \
js_of_ocaml-compiler js_of_ocaml js_of_ocaml-ppx calendar camomile
js_of_ocaml-compiler js_of_ocaml js_of_ocaml-ppx calendar camomile \
visitors
init-submodules:
git submodule update --init

1
dune-project
View File

@ -34,6 +34,7 @@
(dune (>= 2.2))
(ocamlgraph (>= 1.8.8))
(calendar (>= 2.04))
(visitors (>= 20200210))
)
)

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

@ -12,17 +12,24 @@
or implied. See the License for the specific language governing permissions and limitations under
the License. *)
[@@@ocaml.warning "-7"]
(** Abstract syntax tree built by the Catala parser *)
module Pos = Utils.Pos
type constructor = string
type constructor = (string[@opaque])
[@@deriving visitors { variety = "map"; name = "constructor_map"; nude = true }]
(** Constructors are CamelCase *)
type ident = string
type ident = (string[@opaque])
[@@deriving visitors { variety = "map"; name = "ident_map"; nude = true }]
(** Idents are snake_case *)
type qident = ident Pos.marked list
[@@deriving
visitors { variety = "map"; ancestors = [ "Pos.marked_map"; "ident_map" ]; name = "qident_map" }]
type primitive_typ =
| Integer
@ -33,36 +40,69 @@ type primitive_typ =
| Text
| Date
| Named of constructor
[@@deriving
visitors { variety = "map"; ancestors = [ "constructor_map" ]; name = "primitive_typ_map" }]
type base_typ_data = Primitive of primitive_typ | Collection of base_typ_data Pos.marked
[@@deriving
visitors
{
variety = "map";
ancestors = [ "Pos.marked_map"; "primitive_typ_map" ];
name = "base_typ_data_map";
}]
type base_typ = Condition | Data of base_typ_data
[@@deriving
visitors
{ variety = "map"; ancestors = [ "base_typ_data_map" ]; name = "base_typ_map"; nude = true }]
type func_typ = { arg_typ : base_typ Pos.marked; return_typ : base_typ Pos.marked }
[@@deriving
visitors { variety = "map"; ancestors = [ "base_typ_map" ]; name = "func_typ_map"; nude = true }]
type typ = Base of base_typ | Func of func_typ
[@@deriving
visitors { variety = "map"; ancestors = [ "func_typ_map" ]; name = "typ_map"; nude = true }]
type struct_decl_field = {
struct_decl_field_name : ident Pos.marked;
struct_decl_field_typ : typ Pos.marked;
}
[@@deriving
visitors
{ variety = "map"; ancestors = [ "typ_map"; "ident_map" ]; name = "struct_decl_field_map" }]
type struct_decl = {
struct_decl_name : constructor Pos.marked;
struct_decl_fields : struct_decl_field Pos.marked list;
}
[@@deriving
visitors { variety = "map"; ancestors = [ "struct_decl_field_map" ]; name = "struct_decl_map" }]
type enum_decl_case = {
enum_decl_case_name : constructor Pos.marked;
enum_decl_case_typ : typ Pos.marked option;
}
[@@deriving
visitors { variety = "map"; ancestors = [ "typ_map" ]; name = "enum_decl_case_map"; nude = true }]
type enum_decl = {
enum_decl_name : constructor Pos.marked;
enum_decl_cases : enum_decl_case Pos.marked list;
}
[@@deriving
visitors
{ variety = "map"; ancestors = [ "enum_decl_case_map" ]; name = "enum_decl_map"; nude = true }]
type match_case_pattern = constructor Pos.marked list * ident Pos.marked option
[@@deriving
visitors
{
variety = "map";
ancestors = [ "ident_map"; "constructor_map"; "Pos.marked_map" ];
name = "match_case_pattern_map";
}]
type op_kind =
| KInt (** No suffix *)
@ -70,6 +110,7 @@ type op_kind =
| KMoney (** Suffix: [$] *)
| KDate (** Suffix: [@] *)
| KDuration (** Suffix: [^] *)
[@@deriving visitors { variety = "map"; name = "op_kind_map"; nude = true }]
type binop =
| And
@ -84,28 +125,46 @@ type binop =
| Gte of op_kind
| Eq
| Neq
[@@deriving
visitors { variety = "map"; ancestors = [ "op_kind_map" ]; name = "binop_map"; nude = true }]
type unop = Not | Minus of op_kind
[@@deriving
visitors { variety = "map"; ancestors = [ "op_kind_map" ]; name = "unop_map"; nude = true }]
type builtin_expression = Cardinal | IntToDec | GetDay | GetMonth | GetYear
[@@deriving visitors { variety = "map"; name = "builtin_expression_map"; nude = true }]
type literal_date = {
literal_date_day : int Pos.marked;
literal_date_month : int Pos.marked;
literal_date_year : int Pos.marked;
literal_date_day : (int[@opaque]) Pos.marked;
literal_date_month : (int[@opaque]) Pos.marked;
literal_date_year : (int[@opaque]) Pos.marked;
}
[@@deriving
visitors { variety = "map"; ancestors = [ "Pos.marked_map" ]; name = "literal_date_map" }]
type literal_number = Int of Z.t | Dec of Z.t * Z.t
type literal_number = Int of (Z.t[@opaque]) | Dec of (Z.t[@opaque]) * (Z.t[@opaque])
[@@deriving visitors { variety = "map"; name = "literal_number_map"; nude = true }]
type literal_unit = Percent | Year | Month | Day
[@@deriving visitors { variety = "map"; name = "literal_unit_map"; nude = true }]
type money_amount = { money_amount_units : Z.t; money_amount_cents : Z.t }
type money_amount = { money_amount_units : (Z.t[@opaque]); money_amount_cents : (Z.t[@opaque]) }
[@@deriving visitors { variety = "map"; name = "money_amount_map"; nude = true }]
type literal =
| Number of literal_number Pos.marked * literal_unit Pos.marked option
| Bool of bool
| MoneyAmount of money_amount
| Date of literal_date
| LNumber of literal_number Pos.marked * literal_unit Pos.marked option
| LBool of bool
| LMoneyAmount of money_amount
| LDate of literal_date
[@@deriving
visitors
{
variety = "map";
ancestors =
[ "literal_number_map"; "money_amount_map"; "literal_date_map"; "literal_unit_map" ];
name = "literal_map";
}]
type aggregate_func =
| AggregateSum of primitive_typ
@ -141,6 +200,21 @@ and expression =
| Ident of ident
| Dotted of expression Pos.marked * ident Pos.marked
(** Dotted is for both struct field projection and sub-scope variables *)
[@@deriving
visitors
{
variety = "map";
ancestors =
[
"primitive_typ_map";
"match_case_pattern_map";
"literal_map";
"binop_map";
"unop_map";
"builtin_expression_map";
];
name = "expression_map";
}]
type rule = {
rule_label : ident Pos.marked option;
@ -148,8 +222,10 @@ type rule = {
rule_parameter : ident Pos.marked option;
rule_condition : expression Pos.marked option;
rule_name : qident Pos.marked;
rule_consequence : bool Pos.marked;
rule_consequence : (bool[@opaque]) Pos.marked;
}
[@@deriving
visitors { variety = "map"; ancestors = [ "expression_map"; "qident_map" ]; name = "rule_map" }]
type definition = {
definition_label : ident Pos.marked option;
@ -159,84 +235,174 @@ type definition = {
definition_condition : expression Pos.marked option;
definition_expr : expression Pos.marked;
}
[@@deriving
visitors
{ variety = "map"; ancestors = [ "expression_map"; "qident_map" ]; name = "definition_map" }]
type variation_typ = Increasing | Decreasing
[@@deriving visitors { variety = "map"; name = "variation_typ_map" }]
type meta_assertion =
| FixedBy of qident Pos.marked * ident Pos.marked
| VariesWith of qident Pos.marked * expression Pos.marked * variation_typ Pos.marked option
[@@deriving
visitors
{
variety = "map";
ancestors = [ "variation_typ_map"; "qident_map"; "expression_map" ];
name = "meta_assertion_map";
}]
type assertion = {
assertion_condition : expression Pos.marked option;
assertion_content : expression Pos.marked;
}
[@@deriving visitors { variety = "map"; ancestors = [ "expression_map" ]; name = "assertion_map" }]
type scope_use_item =
| Rule of rule
| Definition of definition
| Assertion of assertion
| MetaAssertion of meta_assertion
[@@deriving
visitors
{
variety = "map";
ancestors = [ "meta_assertion_map"; "definition_map"; "assertion_map"; "rule_map" ];
name = "scope_use_item_map";
}]
type scope_use = {
scope_use_condition : expression Pos.marked option;
scope_use_name : constructor Pos.marked;
scope_use_items : scope_use_item Pos.marked list;
}
[@@deriving
visitors
{
variety = "map";
ancestors = [ "expression_map"; "scope_use_item_map" ];
name = "scope_use_map";
}]
type scope_decl_context_scope = {
scope_decl_context_scope_name : ident Pos.marked;
scope_decl_context_scope_sub_scope : constructor Pos.marked;
}
[@@deriving
visitors
{
variety = "map";
ancestors = [ "ident_map"; "constructor_map"; "Pos.marked_map" ];
name = "scope_decl_context_scope_map";
}]
type scope_decl_context_data = {
scope_decl_context_item_name : ident Pos.marked;
scope_decl_context_item_typ : typ Pos.marked;
}
[@@deriving
visitors
{
variety = "map";
ancestors = [ "typ_map"; "ident_map" ];
name = "scope_decl_context_data_map";
}]
type scope_decl_context_item =
| ContextData of scope_decl_context_data
| ContextScope of scope_decl_context_scope
[@@deriving
visitors
{
variety = "map";
ancestors = [ "scope_decl_context_data_map"; "scope_decl_context_scope_map" ];
name = "scope_decl_context_item_map";
}]
type scope_decl = {
scope_decl_name : constructor Pos.marked;
scope_decl_context : scope_decl_context_item Pos.marked list;
}
[@@deriving
visitors
{ variety = "map"; ancestors = [ "scope_decl_context_item_map" ]; name = "scope_decl_map" }]
type code_item =
| ScopeUse of scope_use
| ScopeDecl of scope_decl
| StructDecl of struct_decl
| EnumDecl of enum_decl
[@@deriving
visitors
{
variety = "map";
ancestors = [ "scope_decl_map"; "enum_decl_map"; "struct_decl_map"; "scope_use_map" ];
name = "code_item_map";
}]
type code_block = code_item Pos.marked list
[@@deriving visitors { variety = "map"; ancestors = [ "code_item_map" ]; name = "code_block_map" }]
type source_repr = string Pos.marked
type source_repr = (string[@opaque]) Pos.marked
[@@deriving
visitors { variety = "map"; ancestors = [ "Pos.marked_map" ]; name = "source_repr_map" }]
type law_article = {
law_article_name : string Pos.marked;
law_article_id : string option;
law_article_expiration_date : string option;
law_article_name : (string[@opaque]) Pos.marked;
law_article_id : (string[@opaque]) option;
law_article_expiration_date : (string[@opaque]) option;
}
[@@deriving
visitors { variety = "map"; ancestors = [ "Pos.marked_map" ]; name = "law_article_map" }]
type law_include =
| PdfFile of string Pos.marked * int option
| CatalaFile of string Pos.marked
| LegislativeText of string Pos.marked
| PdfFile of (string[@opaque]) Pos.marked * (int[@opaque]) option
| CatalaFile of (string[@opaque]) Pos.marked
| LegislativeText of (string[@opaque]) Pos.marked
[@@deriving
visitors { variety = "map"; ancestors = [ "Pos.marked_map" ]; name = "law_include_map" }]
type law_article_item = LawText of string | CodeBlock of code_block * source_repr
type law_article_item = LawText of (string[@opaque]) | CodeBlock of code_block * source_repr
[@@deriving
visitors
{
variety = "map";
ancestors = [ "code_block_map"; "source_repr_map" ];
name = "law_article_item_map";
}]
type law_heading = { law_heading_name : string; law_heading_precedence : int }
type law_heading = { law_heading_name : (string[@opaque]); law_heading_precedence : (int[@opaque]) }
[@@deriving visitors { variety = "map"; name = "law_heading_map" }]
type law_structure =
| LawInclude of law_include
| LawHeading of law_heading * law_structure list
| LawArticle of law_article * law_article_item list
| MetadataBlock of code_block * source_repr
| IntermediateText of string
| IntermediateText of (string[@opaque])
[@@deriving
visitors
{
variety = "map";
ancestors =
[
"law_include_map";
"law_article_map";
"law_article_item_map";
"code_block_map";
"source_repr_map";
"law_heading_map";
];
name = "law_structure_map";
}]
type program_item = LawStructure of law_structure
[@@deriving
visitors { variety = "map"; ancestors = [ "law_structure_map" ]; name = "program_item_map" }]
type program = { program_items : program_item list; program_source_files : string list }
type program = { program_items : program_item list; program_source_files : (string[@opaque]) list }
[@@deriving visitors { variety = "map"; ancestors = [ "program_item_map" ]; name = "program_map" }]
type source_file_or_master =
| SourceFile of program_item list

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

@ -138,10 +138,10 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resoluti
| Literal l ->
let untyped_term =
match l with
| Number ((Int i, _), None) -> Scopelang.Ast.ELit (Dcalc.Ast.LInt i)
| Number ((Int i, _), Some (Percent, _)) ->
| LNumber ((Int i, _), None) -> Scopelang.Ast.ELit (Dcalc.Ast.LInt i)
| LNumber ((Int i, _), Some (Percent, _)) ->
Scopelang.Ast.ELit (Dcalc.Ast.LRat (Q.div (Q.of_bigint i) (Q.of_int 100)))
| Number ((Dec (i, f), _), None) ->
| LNumber ((Dec (i, f), _), None) ->
let digits_f =
try int_of_float (ceil (float_of_int (Z.log2 f) *. log 2.0 /. log 10.0))
with Invalid_argument _ -> 0
@ -149,7 +149,7 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resoluti
Scopelang.Ast.ELit
(Dcalc.Ast.LRat
Q.(of_bigint i + (of_bigint f / of_bigint (Z.pow (Z.of_int 10) digits_f))))
| Number ((Dec (i, f), _), Some (Percent, _)) ->
| LNumber ((Dec (i, f), _), Some (Percent, _)) ->
let digits_f =
try int_of_float (ceil (float_of_int (Z.log2 f) *. log 2.0 /. log 10.0))
with Invalid_argument _ -> 0
@ -159,23 +159,23 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resoluti
(Q.div
Q.(of_bigint i + (of_bigint f / of_bigint (Z.pow (Z.of_int 10) digits_f)))
(Q.of_int 100)))
| Bool b -> Scopelang.Ast.ELit (Dcalc.Ast.LBool b)
| MoneyAmount i ->
| LBool b -> Scopelang.Ast.ELit (Dcalc.Ast.LBool b)
| LMoneyAmount i ->
Scopelang.Ast.ELit
(Dcalc.Ast.LMoney Z.((i.money_amount_units * of_int 100) + i.money_amount_cents))
| Number ((Int i, _), Some (Year, _)) ->
| LNumber ((Int i, _), Some (Year, _)) ->
Scopelang.Ast.ELit
(Dcalc.Ast.LDuration (CalendarLib.Date.Period.lmake ~year:(Z.to_int i) ()))
| Number ((Int i, _), Some (Month, _)) ->
| LNumber ((Int i, _), Some (Month, _)) ->
Scopelang.Ast.ELit
(Dcalc.Ast.LDuration (CalendarLib.Date.Period.lmake ~month:(Z.to_int i) ()))
| Number ((Int i, _), Some (Day, _)) ->
| LNumber ((Int i, _), Some (Day, _)) ->
Scopelang.Ast.ELit
(Dcalc.Ast.LDuration (CalendarLib.Date.Period.lmake ~day:(Z.to_int i) ()))
| Number ((Dec (_, _), _), Some ((Year | Month | Day), _)) ->
| LNumber ((Dec (_, _), _), Some ((Year | Month | Day), _)) ->
Errors.raise_spanned_error
"Impossible to specify decimal amounts of days, months or years" pos
| Date date ->
| LDate date ->
if Pos.unmark date.literal_date_month > 12 then
Errors.raise_spanned_error "Month number bigger than 12"
(Pos.get_position date.literal_date_month);
@ -839,7 +839,7 @@ let process_def (precond : Scopelang.Ast.expr Pos.marked Bindlib.box option)
let process_rule (precond : Scopelang.Ast.expr Pos.marked Bindlib.box option)
(scope : Scopelang.Ast.ScopeName.t) (ctxt : Name_resolution.context)
(prgm : Desugared.Ast.program) (rule : Ast.rule) : Desugared.Ast.program =
let consequence_expr = Ast.Literal (Ast.Bool (Pos.unmark rule.rule_consequence)) in
let consequence_expr = Ast.Literal (Ast.LBool (Pos.unmark rule.rule_consequence)) in
let def =
{
Ast.definition_label = rule.rule_label;
@ -863,7 +863,7 @@ let process_assert (precond : Scopelang.Ast.expr Pos.marked Bindlib.box option)
| None -> ass.Ast.assertion_content
| Some cond ->
( Ast.IfThenElse
(cond, ass.Ast.assertion_content, Pos.same_pos_as (Ast.Literal (Ast.Bool true)) cond),
(cond, ass.Ast.assertion_content, Pos.same_pos_as (Ast.Literal (Ast.LBool true)) cond),
Pos.get_position cond ) )
in
let ass =

2
src/catala/catala_surface/dune
View File

@ -4,7 +4,7 @@
zarith_stubs_js calendar)
(public_name catala.surface)
(preprocess
(pps sedlex.ppx)))
(pps sedlex.ppx visitors.ppx)))
(menhir
(modules parser)

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

@ -181,24 +181,24 @@ date_int:
literal:
| l = num_literal u = option(unit_literal) {
(Number (l, u), Pos.from_lpos $sloc)
(LNumber (l, u), Pos.from_lpos $sloc)
}
| money = MONEY_AMOUNT {
let (units, cents) = money in
(MoneyAmount {
(LMoneyAmount {
money_amount_units = units;
money_amount_cents = cents;
}, Pos.from_lpos $sloc)
}
| VERTICAL d = date_int DIV m = date_int DIV y = date_int VERTICAL {
(Date {
(LDate {
literal_date_day = (match !Utils.Cli.locale_lang with `En -> m | `Fr -> d);
literal_date_month = (match !Utils.Cli.locale_lang with `En -> d | `Fr -> m);
literal_date_year = y;
}, Pos.from_lpos $sloc)
}
| TRUE { (Bool true, Pos.from_lpos $sloc) }
| FALSE { (Bool false, Pos.from_lpos $sloc) }
| TRUE { (LBool true, Pos.from_lpos $sloc) }
| FALSE { (LBool false, Pos.from_lpos $sloc) }
compare_op:
| LESSER { (Lt KInt, Pos.from_lpos $sloc) }

18
src/catala/utils/pos.ml
View File

@ -168,3 +168,21 @@ let same_pos_as (x : 'a) ((_, y) : 'b marked) : 'a marked = (x, y)
let unmark_option (x : 'a marked option) : 'a option =
match x with Some x -> Some (unmark x) | None -> None
class ['self] marked_map =
object (_self : 'self)
constraint
'self = < visit_marked : 'env 'a. ('env -> 'a -> 'a) -> 'env -> 'a marked -> 'a marked ; .. >
method visit_marked : 'env 'a. ('env -> 'a -> 'a) -> 'env -> 'a marked -> 'a marked =
fun f env x -> same_pos_as (f env (unmark x)) x
end
class ['self] marked_iter =
object (_self : 'self)
constraint
'self = < visit_marked : 'env 'a. ('env -> 'a -> unit) -> 'env -> 'a marked -> unit ; .. >
method visit_marked : 'env 'a. ('env -> 'a -> unit) -> 'env -> 'a marked -> unit =
fun f env x -> f env (unmark x)
end

18
src/catala/utils/pos.mli
View File

@ -69,3 +69,21 @@ val map_under_mark : ('a -> 'b) -> 'a marked -> 'b marked
val same_pos_as : 'a -> 'b marked -> 'a marked
val unmark_option : 'a marked option -> 'a option
(** Visitors *)
class ['self] marked_map :
object ('self)
constraint
'self = < visit_marked : 'env 'a. ('env -> 'a -> 'a) -> 'env -> 'a marked -> 'a marked ; .. >
method visit_marked : 'env 'a. ('env -> 'a -> 'a) -> 'env -> 'a marked -> 'a marked
end
class ['self] marked_iter :
object ('self)
constraint
'self = < visit_marked : 'env 'a. ('env -> 'a -> unit) -> 'env -> 'a marked -> unit ; .. >
method visit_marked : 'env 'a. ('env -> 'a -> unit) -> 'env -> 'a marked -> unit
end