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

Add support for paths in the parser

Browse Source 
Using them will lead to "not supported yet" errors soon after, but it's a start
to get to handling separate modules.

The idea is that `foo` can now also be `Bar.foo`, `Bar.Baz.foo`, `foo.Struc.fld`
can be `foo.Bar.Baz.Struc.fld`, etc.
The next steps are to enable the lookups to handle this paths, and to provide
ways to load the external modules to feed these lookups.
This commit is contained in:
Louis Gesbert 2023-01-04 16:12:36 +01:00
parent f835225a34
commit 19033669f5
8 changed files with 618 additions and 566 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
compiler/desugared/from_surface.ml
View File

@ -122,11 +122,11 @@ let translate_unop (op : Surface.Ast.unop) pos : Ast.expr boxed =
let disambiguate_constructor
(ctxt : Name_resolution.context)
(constructor : (string Marked.pos option * string Marked.pos) list)
(constructor : (S.path * S.uident Marked.pos) Marked.pos list)
(pos : Pos.t) : EnumName.t * EnumConstructor.t =
let enum, constructor =
let path, constructor =
match constructor with
| [c] -> c
| [c] -> Marked.unmark c
| _ ->
Errors.raise_spanned_error pos
"The deep pattern matching syntactic sugar is not yet supported"
@ -139,8 +139,8 @@ let disambiguate_constructor
"The name of this constructor has not been defined before, maybe it is \
a typo?"
in
match enum with
| None ->
match path with
| [] ->
if EnumName.Map.cardinal possible_c_uids > 1 then
Errors.raise_spanned_error
(Marked.get_mark constructor)
@ -152,7 +152,7 @@ let disambiguate_constructor
Format.fprintf fmt "%a" EnumName.format_t s_name))
(EnumName.Map.bindings possible_c_uids);
EnumName.Map.choose possible_c_uids
| Some enum -> (
| [enum] -> (
try
(* The path is fully qualified *)
let e_uid = Name_resolution.get_enum ctxt enum in
@ -166,6 +166,7 @@ let disambiguate_constructor
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark enum)
"Enum %s has not been defined before" (Marked.unmark enum))
| _ -> Errors.raise_spanned_error pos "Qualified paths are not supported yet"
let int100 = Runtime.integer_of_int 100
let rat100 = Runtime.decimal_of_integer int100
@ -296,7 +297,7 @@ let rec translate_expr
correct calendar day")
in
Expr.elit lit emark
| Ident x -> (
| Ident ([], (x, pos)) -> (
(* first we check whether this is a local var, then we resort to scope-wide
variables *)
match IdentName.Map.find_opt x ctxt.local_var_idmap with
@ -348,9 +349,12 @@ let rec translate_expr
| Some uid ->
Expr.make_var uid emark
(* the whole box thing is to accomodate for this case *))
| Dotted (e, c, x) -> (
match Marked.unmark e with
| Ident y when Name_resolution.is_subscope_uid scope ctxt y ->
| Ident (_path, _x) ->
Errors.raise_spanned_error pos "Qualified paths are not supported yet"
| Dotted (e, ((path, x), _ppos)) -> (
match path, Marked.unmark e with
| [], Ident ([], (y, _)) when Name_resolution.is_subscope_uid scope ctxt y
->
(* In this case, y.x is a subscope variable *)
let subscope_uid, subscope_real_uid =
match IdentName.Map.find y scope_ctxt.var_idmap with
@ -368,17 +372,19 @@ let rec translate_expr
(* In this case e.x is the struct field x access of expression e *)
let e = translate_expr scope inside_definition_of ctxt e in
let str =
Option.map
(fun c ->
try Name_resolution.get_struct ctxt c
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark c)
"Structure %s was not declared" (Marked.unmark c))
c
match path with
| [] -> None
| [c] -> (
try Some (Name_resolution.get_struct ctxt c)
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark c)
"Structure %s was not declared" (Marked.unmark c))
| _ ->
Errors.raise_spanned_error pos "Qualified paths are not supported yet"
in
Expr.edstructaccess e (Marked.unmark x) str emark)
| FunCall (f, arg) -> Expr.eapp (rec_helper f) [rec_helper arg] emark
| ScopeCall (sc_name, fields) ->
| ScopeCall ((([], sc_name), _), fields) ->
let called_scope = Name_resolution.get_scope ctxt sc_name in
let scope_def = ScopeName.Map.find called_scope ctxt.scopes in
let in_struct =
@ -412,6 +418,8 @@ let rec translate_expr
ScopeVar.Map.empty fields
in
Expr.escopecall called_scope in_struct emark
| ScopeCall (((_, _sc_name), _), _fields) ->
Errors.raise_spanned_error pos "Qualified paths are not supported yet"
| 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
@ -422,7 +430,7 @@ let rec translate_expr
[tau] pos
in
Expr.eapp fn [rec_helper e1] emark
| StructLit (s_name, fields) ->
| StructLit ((([], s_name), _), fields) ->
let s_uid =
match IdentName.Map.find_opt (Marked.unmark s_name) ctxt.typedefs with
| Some (Name_resolution.TStruct s_uid) -> s_uid
@ -463,7 +471,9 @@ let rec translate_expr
expected_s_fields;
Expr.estruct s_uid s_fields emark
| EnumInject (enum, (constructor, pos_constructor), payload) -> (
| StructLit (((_, _s_name), _), _fields) ->
Errors.raise_spanned_error pos "Qualified paths are not supported yet"
| EnumInject (((path, (constructor, pos_constructor)), _), payload) -> (
let possible_c_uids =
try IdentName.Map.find constructor ctxt.constructor_idmap
with Not_found ->
@ -473,8 +483,8 @@ let rec translate_expr
in
let mark_constructor = Untyped { pos = pos_constructor } in
match enum with
| None ->
match path with
| [] ->
if
(* No constructor name was specified *)
EnumName.Map.cardinal possible_c_uids > 1
@ -497,7 +507,7 @@ let rec translate_expr
| Some e' -> e'
| None -> Expr.elit LUnit mark_constructor)
c_uid e_uid emark
| Some enum -> (
| [enum] -> (
try
(* The path has been fully qualified *)
let e_uid = Name_resolution.get_enum ctxt enum in
@ -516,7 +526,9 @@ let rec translate_expr
(Marked.unmark enum) constructor
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark enum)
"Enum %s has not been defined before" (Marked.unmark enum)))
"Enum %s has not been defined before" (Marked.unmark enum))
| _ ->
Errors.raise_spanned_error pos "Qualified paths are not supported yet")
| MatchWith (e1, (cases, _cases_pos)) ->
let e1 = translate_expr scope inside_definition_of ctxt e1 in
let cases_d, e_uid =

11
compiler/desugared/name_resolution.ml
View File

@ -297,7 +297,7 @@ let rec process_base_typ
| Surface.Ast.Date -> TLit TDate, typ_pos
| Surface.Ast.Boolean -> TLit TBool, typ_pos
| Surface.Ast.Text -> raise_unsupported_feature "text type" typ_pos
| Surface.Ast.Named ident -> (
| Surface.Ast.Named ([], (ident, _pos)) -> (
match IdentName.Map.find_opt ident ctxt.typedefs with
| Some (TStruct s_uid) -> TStruct s_uid, typ_pos
| Some (TEnum e_uid) -> TEnum e_uid, typ_pos
@ -307,7 +307,10 @@ let rec process_base_typ
Errors.raise_spanned_error typ_pos
"Unknown type \"%a\", not a struct or enum previously declared"
(Cli.format_with_style [ANSITerminal.yellow])
ident))
ident)
| Surface.Ast.Named (_path, (_ident, _pos)) ->
Errors.raise_spanned_error typ_pos "Qualified paths are not supported yet"
)
(** Process a type (function or not) *)
let process_type (ctxt : context) ((naked_typ, typ_pos) : Surface.Ast.typ) : typ
@ -671,8 +674,8 @@ let rec process_law_structure
(** {1 Scope uses pass} *)
let get_def_key
(name : Surface.Ast.qident)
(state : Surface.Ast.ident Marked.pos option)
(name : Surface.Ast.scope_var)
(state : Surface.Ast.lident Marked.pos option)
(scope_uid : ScopeName.t)
(ctxt : context)
(pos : Pos.t) : Ast.ScopeDef.t =

4
compiler/desugared/name_resolution.mli
View File

@ -129,8 +129,8 @@ val add_def_local_var : context -> IdentName.t -> context * Ast.expr Var.t
(** Adds a binding to the context *)
val get_def_key :
Surface.Ast.qident ->
Surface.Ast.ident Marked.pos option ->
Surface.Ast.scope_var ->
Surface.Ast.lident Marked.pos option ->
ScopeName.t ->
context ->
Pos.t ->

153
compiler/surface/ast.ml
View File

@ -30,33 +30,49 @@ open Catala_utils
(** {1 Type definitions} *)
type constructor = (string[@opaque])
type uident = (string[@opaque])
[@@deriving
visitors { variety = "map"; name = "constructor_map"; nude = true },
visitors { variety = "iter"; name = "constructor_iter"; nude = true }]
visitors { variety = "map"; name = "uident_map"; nude = true },
visitors { variety = "iter"; name = "uident_iter"; nude = true }]
(** Constructors are CamelCase *)
type ident = (string[@opaque])
type lident = (string[@opaque])
[@@deriving
visitors { variety = "map"; name = "ident_map"; nude = true },
visitors { variety = "iter"; name = "ident_iter"; nude = true }]
visitors { variety = "map"; name = "lident_map"; nude = true },
visitors { variety = "iter"; name = "lident_iter"; nude = true }]
(** Idents are snake_case *)
type qident = ident Marked.pos list
type path = uident Marked.pos list
[@@deriving
visitors
{
variety = "map";
ancestors = ["Marked.pos_map"; "ident_map"];
name = "qident_map";
ancestors = ["Marked.pos_map"; "uident_map"];
name = "path_map";
},
visitors
{
variety = "iter";
ancestors = ["Marked.pos_iter"; "ident_iter"];
name = "qident_iter";
ancestors = ["Marked.pos_iter"; "uident_iter"];
name = "path_iter";
}]
type scope_var = lident Marked.pos list
[@@deriving
visitors
{
variety = "map";
ancestors = ["Marked.pos_map"; "lident_map"];
name = "scope_var_map";
},
visitors
{
variety = "iter";
ancestors = ["Marked.pos_iter"; "lident_iter"];
name = "scope_var_iter";
}]
(** [foo.bar] in binding position: used to specify variables of subscopes *)
type primitive_typ =
| Integer
| Decimal
@ -65,18 +81,18 @@ type primitive_typ =
| Duration
| Text
| Date
| Named of constructor
| Named of path * uident Marked.pos
[@@deriving
visitors
{
variety = "map";
ancestors = ["constructor_map"];
ancestors = ["path_map"; "uident_map"];
name = "primitive_typ_map";
},
visitors
{
variety = "iter";
ancestors = ["constructor_iter"];
ancestors = ["path_iter"; "uident_iter"];
name = "primitive_typ_iter";
}]
@ -154,25 +170,25 @@ and naked_typ = Base of base_typ | Func of func_typ
}]
type struct_decl_field = {
struct_decl_field_name : ident Marked.pos;
struct_decl_field_name : lident Marked.pos;
struct_decl_field_typ : typ;
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["typ_map"; "ident_map"];
ancestors = ["typ_map"; "lident_map"];
name = "struct_decl_field_map";
},
visitors
{
variety = "iter";
ancestors = ["typ_iter"; "ident_iter"];
ancestors = ["typ_iter"; "lident_iter"];
name = "struct_decl_field_iter";
}]
type struct_decl = {
struct_decl_name : constructor Marked.pos;
struct_decl_name : uident Marked.pos;
struct_decl_fields : struct_decl_field Marked.pos list;
}
[@@deriving
@ -190,7 +206,7 @@ type struct_decl = {
}]
type enum_decl_case = {
enum_decl_case_name : constructor Marked.pos;
enum_decl_case_name : uident Marked.pos;
enum_decl_case_typ : typ option;
}
[@@deriving
@ -210,7 +226,7 @@ type enum_decl_case = {
}]
type enum_decl = {
enum_decl_name : constructor Marked.pos;
enum_decl_name : uident Marked.pos;
enum_decl_cases : enum_decl_case Marked.pos list;
}
[@@deriving
@ -230,19 +246,19 @@ type enum_decl = {
}]
type match_case_pattern =
(constructor Marked.pos option * constructor Marked.pos) list
* ident Marked.pos option
(path * uident Marked.pos) Marked.pos list * lident Marked.pos option
[@@deriving
visitors
{
variety = "map";
ancestors = ["ident_map"; "constructor_map"; "Marked.pos_map"];
ancestors = ["path_map"; "lident_map"; "uident_map"; "Marked.pos_map"];
name = "match_case_pattern_map";
},
visitors
{
variety = "iter";
ancestors = ["ident_iter"; "constructor_iter"; "Marked.pos_iter"];
ancestors =
["path_iter"; "lident_iter"; "uident_iter"; "Marked.pos_iter"];
name = "match_case_pattern_iter";
}]
@ -384,10 +400,10 @@ type literal =
}]
type collection_op =
| Exists of { predicate : ident Marked.pos * expression }
| Forall of { predicate : ident Marked.pos * expression }
| Map of { f : ident Marked.pos * expression }
| Filter of { f : ident Marked.pos * expression }
| Exists of { predicate : lident Marked.pos * expression }
| Forall of { predicate : lident Marked.pos * expression }
| Map of { f : lident Marked.pos * expression }
| Filter of { f : lident Marked.pos * expression }
| AggregateSum of { typ : primitive_typ }
(* it would be nice to remove the need for specifying the type here like for
extremums, but we need an additionl overload for "neutral element for
@ -396,7 +412,7 @@ type collection_op =
| AggregateArgExtremum of {
max : bool;
default : expression;
f : ident Marked.pos * expression;
f : lident Marked.pos * expression;
}
and explicit_match_case = {
@ -418,16 +434,19 @@ and naked_expression =
| MemCollection of expression * expression
| TestMatchCase of expression * match_case_pattern Marked.pos
| FunCall of expression * expression
| ScopeCall of constructor Marked.pos * (ident Marked.pos * expression) list
| LetIn of ident Marked.pos * expression * expression
| ScopeCall of
(path * uident Marked.pos) Marked.pos
* (lident Marked.pos * expression) list
| LetIn of lident Marked.pos * expression * expression
| Builtin of builtin_expression
| Literal of literal
| EnumInject of
constructor Marked.pos option * constructor Marked.pos * expression option
| StructLit of constructor Marked.pos * (ident Marked.pos * expression) list
| EnumInject of (path * uident Marked.pos) Marked.pos * expression option
| StructLit of
(path * uident Marked.pos) Marked.pos
* (lident Marked.pos * expression) list
| ArrayLit of expression list
| Ident of ident
| Dotted of expression * constructor Marked.pos option * ident Marked.pos
| Ident of path * lident Marked.pos
| Dotted of expression * (path * lident Marked.pos) Marked.pos
(** Dotted is for both struct field projection and sub-scope variables *)
[@@deriving
visitors
@ -462,66 +481,66 @@ and naked_expression =
type exception_to =
| NotAnException
| UnlabeledException
| ExceptionToLabel of ident Marked.pos
| ExceptionToLabel of lident Marked.pos
[@@deriving
visitors
{
variety = "map";
ancestors = ["ident_map"; "Marked.pos_map"];
ancestors = ["lident_map"; "Marked.pos_map"];
name = "exception_to_map";
},
visitors
{
variety = "iter";
ancestors = ["ident_iter"; "Marked.pos_iter"];
ancestors = ["lident_iter"; "Marked.pos_iter"];
name = "exception_to_iter";
}]
type rule = {
rule_label : ident Marked.pos option;
rule_label : lident Marked.pos option;
rule_exception_to : exception_to;
rule_parameter : ident Marked.pos option;
rule_parameter : lident Marked.pos option;
rule_condition : expression option;
rule_name : qident Marked.pos;
rule_name : scope_var Marked.pos;
rule_id : Shared_ast.RuleName.t; [@opaque]
rule_consequence : (bool[@opaque]) Marked.pos;
rule_state : ident Marked.pos option;
rule_state : lident Marked.pos option;
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["expression_map"; "qident_map"; "exception_to_map"];
ancestors = ["expression_map"; "scope_var_map"; "exception_to_map"];
name = "rule_map";
},
visitors
{
variety = "iter";
ancestors = ["expression_iter"; "qident_iter"; "exception_to_iter"];
ancestors = ["expression_iter"; "scope_var_iter"; "exception_to_iter"];
name = "rule_iter";
}]
type definition = {
definition_label : ident Marked.pos option;
definition_label : lident Marked.pos option;
definition_exception_to : exception_to;
definition_name : qident Marked.pos;
definition_parameter : ident Marked.pos option;
definition_name : scope_var Marked.pos;
definition_parameter : lident Marked.pos option;
definition_condition : expression option;
definition_id : Shared_ast.RuleName.t; [@opaque]
definition_expr : expression;
definition_state : ident Marked.pos option;
definition_state : lident Marked.pos option;
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["expression_map"; "qident_map"; "exception_to_map"];
ancestors = ["expression_map"; "scope_var_map"; "exception_to_map"];
name = "definition_map";
},
visitors
{
variety = "iter";
ancestors = ["expression_iter"; "qident_iter"; "exception_to_iter"];
ancestors = ["expression_iter"; "scope_var_iter"; "exception_to_iter"];
name = "definition_iter";
}]
@ -531,20 +550,20 @@ type variation_typ = Increasing | Decreasing
visitors { variety = "iter"; name = "variation_typ_iter" }]
type meta_assertion =
| FixedBy of qident Marked.pos * ident Marked.pos
| FixedBy of scope_var Marked.pos * lident Marked.pos
| VariesWith of
qident Marked.pos * expression * variation_typ Marked.pos option
scope_var Marked.pos * expression * variation_typ Marked.pos option
[@@deriving
visitors
{
variety = "map";
ancestors = ["variation_typ_map"; "qident_map"; "expression_map"];
ancestors = ["variation_typ_map"; "scope_var_map"; "expression_map"];
name = "meta_assertion_map";
},
visitors
{
variety = "iter";
ancestors = ["variation_typ_iter"; "qident_iter"; "expression_iter"];
ancestors = ["variation_typ_iter"; "scope_var_iter"; "expression_iter"];
name = "meta_assertion_iter";
}]
@ -590,7 +609,7 @@ type scope_use_item =
type scope_use = {
scope_use_condition : expression option;
scope_use_name : constructor Marked.pos;
scope_use_name : uident Marked.pos;
scope_use_items : scope_use_item Marked.pos list;
}
[@@deriving
@ -631,8 +650,8 @@ type scope_decl_context_io = {
}]
type scope_decl_context_scope = {
scope_decl_context_scope_name : ident Marked.pos;
scope_decl_context_scope_sub_scope : constructor Marked.pos;
scope_decl_context_scope_name : lident Marked.pos;
scope_decl_context_scope_sub_scope : uident Marked.pos;
scope_decl_context_scope_attribute : scope_decl_context_io;
}
[@@deriving
@ -641,8 +660,8 @@ type scope_decl_context_scope = {
variety = "map";
ancestors =
[
"ident_map";
"constructor_map";
"lident_map";
"uident_map";
"scope_decl_context_io_map";
"Marked.pos_map";
];
@ -653,8 +672,8 @@ type scope_decl_context_scope = {
variety = "iter";
ancestors =
[
"ident_iter";
"constructor_iter";
"lident_iter";
"uident_iter";
"scope_decl_context_io_iter";
"Marked.pos_iter";
];
@ -662,22 +681,22 @@ type scope_decl_context_scope = {
}]
type scope_decl_context_data = {
scope_decl_context_item_name : ident Marked.pos;
scope_decl_context_item_name : lident Marked.pos;
scope_decl_context_item_typ : typ;
scope_decl_context_item_attribute : scope_decl_context_io;
scope_decl_context_item_states : ident Marked.pos list;
scope_decl_context_item_states : lident Marked.pos list;
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["typ_map"; "scope_decl_context_io_map"; "ident_map"];
ancestors = ["typ_map"; "scope_decl_context_io_map"; "lident_map"];
name = "scope_decl_context_data_map";
},
visitors
{
variety = "iter";
ancestors = ["typ_iter"; "scope_decl_context_io_iter"; "ident_iter"];
ancestors = ["typ_iter"; "scope_decl_context_io_iter"; "lident_iter"];
name = "scope_decl_context_data_iter";
}]
@ -701,7 +720,7 @@ type scope_decl_context_item =
}]
type scope_decl = {
scope_decl_name : constructor Marked.pos;
scope_decl_name : uident Marked.pos;
scope_decl_context : scope_decl_context_item Marked.pos list;
}
[@@deriving

594
compiler/surface/parser.messages
View File

File diff suppressed because it is too large Load Diff

334
compiler/surface/parser.mly
View File

@ -25,10 +25,6 @@
val lex_builtin: string -> Ast.builtin_expression option
end>
%type <Ast.source_file> source_file
%start source_file
(* The token is returned for every line of law text, make them right-associative
so that we concat them efficiently as much as possible. *)
%right LAW_TEXT
@ -37,18 +33,75 @@ end>
%right top_expr
%right ALT
%right let_expr IS
%right AND OR XOR
%right AND OR XOR (* Desugaring enforces proper parens later on *)
%nonassoc GREATER GREATER_EQUAL LESSER LESSER_EQUAL EQUAL NOT_EQUAL
%left PLUS MINUS PLUSPLUS
%left MULT DIV
%right apply OF CONTAINS FOR SUCH WITH
%right unop_expr
%right CONTENT
%nonassoc UIDENT
%left DOT
(* Types of all rules, in order. Without this, Menhir type errors are nearly
impossible to debug because of inlining *)
%type<Ast.uident Marked.pos> addpos(UIDENT)
%type<Pos.t> pos(CONDITION)
%type<Ast.primitive_typ> typ_base
%type<Ast.base_typ_data> typ
%type<Ast.uident Marked.pos> uident
%type<Ast.lident Marked.pos> lident
%type<Ast.scope_var> scope_var
%type<Ast.path * Ast.uident Marked.pos> quident
%type<Ast.path * Ast.lident Marked.pos> qlident
%type<Ast.expression> expression
%type<Ast.naked_expression> naked_expression
%type<Ast.lident Marked.pos * expression> struct_content_field
%type<Ast.naked_expression> struct_or_enum_inject
%type<Ast.literal_number> num_literal
%type<Ast.literal_unit> unit_literal
%type<Ast.literal> literal
%type<(Ast.lident Marked.pos * expression) list> scope_call_args
%type<bool> minmax
%type<Ast.unop> unop
%type<Ast.binop> binop
%type<Ast.match_case_pattern> constructor_binding
%type<Ast.match_case> match_arm
%type<Ast.expression> condition_consequence
%type<Ast.scope_var Marked.pos * Ast.lident Marked.pos option> rule_expr
%type<bool> rule_consequence
%type<Ast.rule> rule
%type<Ast.lident Marked.pos> definition_parameters
%type<Ast.lident Marked.pos> label
%type<Ast.lident Marked.pos> state
%type<Ast.exception_to> exception_to
%type<Ast.definition> definition
%type<Ast.variation_typ> variation_type
%type<Ast.scope_use_item> assertion
%type<Ast.scope_use_item> scope_item
%type<Ast.lident Marked.pos * Ast.base_typ Marked.pos> struct_scope_base
%type<Ast.base_typ_data Marked.pos> struct_scope_func
%type<Ast.struct_decl_field> struct_scope
%type<Ast.io_input> scope_decl_item_attribute_input
%type<bool> scope_decl_item_attribute_output
%type<Ast.scope_decl_context_io> scope_decl_item_attribute
%type<Ast.scope_decl_context_item> scope_decl_item
%type<Ast.enum_decl_case> enum_decl_line
%type<Ast.code_item> code_item
%type<Ast.code_block> code
%type<Ast.code_block * string Marked.pos> metadata_block
%type<Ast.law_heading> law_heading
%type<string> law_text
%type<Ast.law_structure> source_file_item
%type<Ast.law_structure list> source_file
%start source_file
%%
let pos(x) ==
| ~=x ; { Pos.from_lpos $loc }
| x ; { Pos.from_lpos $loc }
let addpos(x) ==
| ~=x ; { x, Pos.from_lpos $loc(x) }
@ -61,41 +114,59 @@ let typ_base :=
| TEXT ; { Text }
| DECIMAL ; { Decimal }
| DATE ; { Date }
| c = UIDENT ; <Named>
| c = quident ; { let path, uid = c in Named (path, uid) }
let typ :=
| t = typ_base ; <Primitive>
| COLLECTION ; t = addpos(typ) ; <Collection>
let qident ==
| b = separated_nonempty_list(DOT, ident) ; <>
let uident ==
| ~ = addpos(UIDENT) ; <>
(* let path :=
* | { [] } %prec qpath
* | ~=constructor ; DOT ; ~=path ; <List.cons> %prec qpath *)
(* Not yet supported, at the moment it's just an option: *)
let path ==
| { None }
| ~=constructor ; DOT ; <Some>
let lident :=
| i = LIDENT ; {
match Localisation.lex_builtin i with
| Some _ ->
Errors.raise_spanned_error
(Pos.from_lpos $sloc)
"Reserved builtin name"
| None ->
(i, Pos.from_lpos $sloc)
}
let expression ==
| e = addpos(naked_expression) ; { (e: expression) }
let scope_var ==
| b = separated_nonempty_list(DOT, addpos(LIDENT)) ; <>
let naked_expression :=
| q = LIDENT ; {
(match Localisation.lex_builtin q with
| Some b -> Builtin b
| None -> Ident q)
let quident :=
| uid = uident ; DOT ; quid = quident ; {
let path, quid = quid in uid :: path, quid
}
| id = uident ; { [], id }
let qlident :=
| uid = uident ; DOT ; qlid = qlident ; {
let path, lid = qlid in uid :: path, lid
}
| id = lident ; { [], id }
let expression :=
| e = addpos(naked_expression) ; <>
let naked_expression ==
| id = addpos(LIDENT) ; {
match Localisation.lex_builtin (Marked.unmark id) with
| Some b -> Builtin b
| None -> Ident ([], id)
}
| uid = uident ; DOT ; qlid = qlident ; {
let path, lid = qlid in Ident (uid :: path, lid)
}
| l = literal ; {
Literal l
}
| LPAREN ; e = expression ; RPAREN ; <Paren>
| e = expression ;
DOT ; c = path ;
i = ident ; {
Dotted (e, c, i)
}
DOT ; i = addpos(qlident) ; <Dotted>
| CARDINAL ; {
Builtin Cardinal
}
@ -105,9 +176,8 @@ let naked_expression :=
| MONEY ; {
Builtin ToMoney
}
| LBRACKET ; l = separated_list(SEMICOLON, expression) ; RBRACKET ; {
ArrayLit l
}
| LBRACKET ; l = separated_list(SEMICOLON, expression) ; RBRACKET ;
<ArrayLit>
| e = struct_or_enum_inject ; <>
| e1 = expression ;
OF ;
@ -115,7 +185,7 @@ let naked_expression :=
FunCall (e1, e2)
} %prec apply
| OUTPUT ; OF ;
c = constructor ;
c = addpos(quident) ;
fields = option(scope_call_args) ; {
let fields = Option.value ~default:[] fields in
ScopeCall (c, fields)
@ -134,7 +204,7 @@ let naked_expression :=
CollectionOp (AggregateSum { typ = Marked.unmark typ }, coll)
} %prec apply
| f = expression ;
FOR ; i = ident ;
FOR ; i = lident ;
AMONG ; coll = expression ; {
CollectionOp (Map {f = i, f}, coll)
} %prec apply
@ -144,7 +214,7 @@ let naked_expression :=
default = expression ; {
CollectionOp (AggregateExtremum { max; default }, coll)
} %prec apply
| op = unop ; e = expression ; {
| op = addpos(unop) ; e = expression ; {
Unop (op, e)
} %prec unop_expr
| e1 = expression ;
@ -152,12 +222,12 @@ let naked_expression :=
e2 = expression ; {
Binop (binop, e1, e2)
}
| EXISTS ; i = ident ;
| EXISTS ; i = lident ;
AMONG ; coll = expression ;
SUCH ; THAT ; predicate = expression ; {
CollectionOp (Exists {predicate = i, predicate}, coll)
} %prec let_expr
| FOR ; ALL ; i = ident ;
| FOR ; ALL ; i = lident ;
AMONG ; coll = expression ;
WE_HAVE ; predicate = expression ; {
CollectionOp (Forall {predicate = i, predicate}, coll)
@ -172,23 +242,23 @@ let naked_expression :=
ELSE ; e3 = expression ; {
IfThenElse (e1, e2, e3)
} %prec let_expr
| LET ; id = ident ;
| LET ; id = lident ;
DEFINED_AS ; e1 = expression ;
IN ; e2 = expression ; {
LetIn (id, e1, e2)
} %prec let_expr
| i = ident ;
| i = lident ;
AMONG ; coll = expression ;
SUCH ; THAT ; f = expression ; {
CollectionOp (Filter {f = i, f}, coll)
} %prec top_expr
| fmap = expression ;
FOR ; i = ident ;
FOR ; i = lident ;
AMONG ; coll = expression ;
SUCH ; THAT ; ffilt = expression ; {
CollectionOp (Map {f = i, fmap}, (CollectionOp (Filter {f = i, ffilt}, coll), Pos.from_lpos $loc))
} %prec top_expr
| i = ident ;
| i = lident ;
AMONG ; coll = expression ;
SUCH ; THAT ; f = expression ;
IS ; max = minmax ;
@ -198,20 +268,14 @@ let naked_expression :=
let struct_content_field :=
| field = ident ; COLON ; e = expression ; <>
let enum_content_opt :=
| {None} %prec CONTENT
| CONTENT ; ~ = expression ; <Some> %prec CONTENT
| field = lident ; COLON ; e = expression ; <>
let struct_or_enum_inject ==
| ~ = path ;
~ = constructor ;
data = enum_content_opt ; {
EnumInject(path, constructor, data)
| uid = addpos(quident) ;
data = option(preceded(CONTENT,expression)) ; {
EnumInject(uid, data)
}
| _ = path ;
c = constructor ;
| c = addpos(quident) ;
LBRACE ;
fields = nonempty_list(preceded(ALT, struct_content_field)) ;
RBRACE ; {
@ -263,8 +327,8 @@ let minmax ==
| MINIMUM ; { false }
let unop ==
| NOT ; { (Not, Pos.from_lpos $sloc) }
| k = MINUS ; { (Minus k, Pos.from_lpos $sloc) }
| NOT ; { Not }
| k = MINUS ; <Minus>
let binop ==
| k = MULT ; <Mult>
@ -283,11 +347,11 @@ let binop ==
| XOR ; { Xor }
let constructor_binding :=
| ~ = path; ~ = constructor ; OF ; ~ = ident ; {
([path, constructor], Some ident)
| uid = addpos(quident) ; OF ; lid = lident ; {
([uid], Some lid)
}
| ~ = path; ~ = constructor ; {
([path, constructor], None)
| uid = addpos(quident) ; {
([uid], None)
} %prec apply
let match_arm :=
@ -301,14 +365,11 @@ let match_arm :=
}
} %prec ALT
let condition ==
| UNDER_CONDITION ; e = expression ; <>
let condition_consequence :=
| cond = condition ; CONSEQUENCE ; { cond }
| UNDER_CONDITION ; c = expression ; CONSEQUENCE ; <>
let rule_expr :=
| i = addpos(qident) ; p = option(definition_parameters) ; <>
| i = addpos(scope_var) ; p = option(definition_parameters) ; <>
let rule_consequence :=
| flag = option(NOT); FILLED ; {
@ -340,20 +401,20 @@ let rule :=
Pos.from_lpos $sloc);
rule_consequence = cons;
rule_state = state;
}, $sloc
}
}
let definition_parameters :=
| OF ; i = ident ; { i }
| OF ; i = lident ; <>
let label :=
| LABEL ; i = ident ; { i }
| LABEL ; i = lident ; <>
let state :=
| STATE ; s = ident ; { s }
| STATE ; s = lident ; <>
let exception_to :=
| EXCEPTION ; i = option(ident) ; {
| EXCEPTION ; i = option(lident) ; {
match i with
| None -> UnlabeledException
| Some x -> ExceptionToLabel x
@ -363,7 +424,7 @@ let definition :=
| label = option(label);
except = option(exception_to) ;
DEFINITION ;
name = addpos(qident) ;
name = addpos(scope_var) ;
param = option(definition_parameters) ;
state = option(state) ;
cond = option(condition_consequence) ;
@ -385,70 +446,47 @@ let definition :=
Pos.from_lpos $sloc);
definition_expr = e;
definition_state = state;
}, $sloc
}
}
let variation_type :=
| INCREASING ; { (Increasing, Pos.from_lpos $sloc) }
| DECREASING ; { (Decreasing, Pos.from_lpos $sloc) }
let assertion_base :=
| e = expression ; { let (e, _) = e in (e, Pos.from_lpos $sloc) }
| INCREASING ; { Increasing }
| DECREASING ; { Decreasing }
let assertion :=
| cond = option(condition_consequence) ;
base = assertion_base ; {
base = expression ; {
(Assertion {
assertion_condition = cond;
assertion_content = base;
})
}
| FIXED ; q = addpos(qident) ; BY ; i = ident ; {
| FIXED ; q = addpos(scope_var) ; BY ; i = lident ; {
MetaAssertion (FixedBy (q, i))
}
| VARIES ; q = addpos(qident) ;
| VARIES ; q = addpos(scope_var) ;
WITH_V ; e = expression ;
t = option(variation_type) ; {
t = option(addpos(variation_type)) ; {
MetaAssertion (VariesWith (q, e, t))
}
let scope_item :=
| r = rule ; {
let (r, _) = r in (Rule r, Pos.from_lpos $sloc)
}
| d = definition ; {
let (d, _) = d in (Definition d, Pos.from_lpos $sloc)
}
| ASSERTION ; contents = assertion ; {
(contents, Pos.from_lpos $sloc)
}
let ident :=
| i = LIDENT ; {
match Localisation.lex_builtin i with
| Some _ ->
Errors.raise_spanned_error
(Pos.from_lpos $sloc)
"Reserved builtin name"
| None ->
(i, Pos.from_lpos $sloc)
}
let condition_pos :=
| CONDITION ; { Pos.from_lpos $sloc }
| r = rule ; <Rule>
| d = definition ; <Definition>
| ASSERTION ; contents = assertion ; <>
let struct_scope_base :=
| DATA ; i = ident ;
| DATA ; i = lident ;
CONTENT ; t = addpos(typ) ; {
let t, pos = t in
(i, (Data t, pos))
}
| pos = condition_pos ; i = ident ; {
| pos = pos(CONDITION) ; i = lident ; {
(i, (Condition, pos))
}
let struct_scope_func ==
| DEPENDS ; t = addpos(typ) ; { t }
| DEPENDS ; t = addpos(typ) ; <>
let struct_scope :=
| name_and_typ = struct_scope_base ;
@ -464,20 +502,20 @@ let struct_scope :=
arg_typ = (Data arg_typ, arg_pos);
return_typ = (typ, typ_pos);
}, Pos.from_lpos $sloc ;
}, Pos.from_lpos $sloc
}
}
let scope_decl_item_attribute_input :=
| CONTEXT ; { Context, Pos.from_lpos $sloc }
| INPUT ; { Input, Pos.from_lpos $sloc }
| CONTEXT ; { Context }
| INPUT ; { Input }
let scope_decl_item_attribute_output :=
| OUTPUT ; { true, Pos.from_lpos $sloc }
| { false, Pos.from_lpos $sloc }
| OUTPUT ; { true }
| { false }
let scope_decl_item_attribute :=
| input = scope_decl_item_attribute_input ;
output = scope_decl_item_attribute_output ; {
| input = addpos(scope_decl_item_attribute_input) ;
output = addpos(scope_decl_item_attribute_output) ; {
{
scope_decl_context_io_input = input;
scope_decl_context_io_output = output
@ -499,11 +537,11 @@ let scope_decl_item_attribute :=
let scope_decl_item :=
| attr = scope_decl_item_attribute ;
i = ident ;
i = lident ;
CONTENT ; t = addpos(typ) ;
func_typ = option(struct_scope_func) ;
states = list(state) ; {
(ContextData {
ContextData {
scope_decl_context_item_name = i;
scope_decl_context_item_attribute = attr;
scope_decl_context_item_typ =
@ -516,21 +554,21 @@ let scope_decl_item :=
return_typ = (Data typ, typ_pos);
}, Pos.from_lpos $sloc);
scope_decl_context_item_states = states;
}, Pos.from_lpos $sloc)
}
}
| i = ident ; SCOPE ; c = constructor ; {
(ContextScope{
| i = lident ; SCOPE ; c = uident ; {
ContextScope{
scope_decl_context_scope_name = i;
scope_decl_context_scope_sub_scope = c;
scope_decl_context_scope_attribute = {
scope_decl_context_io_input = (Internal, Pos.from_lpos $sloc);
scope_decl_context_io_output = (false, Pos.from_lpos $sloc);
};
}, Pos.from_lpos $sloc)
}
}
| attr = scope_decl_item_attribute ;
i = ident ;
_condition = CONDITION ;
i = lident ;
pos_condition = pos(CONDITION) ;
func_typ = option(struct_scope_func) ;
states = list(state) ; {
ContextData {
@ -538,73 +576,66 @@ let scope_decl_item :=
scope_decl_context_item_attribute = attr;
scope_decl_context_item_typ =
(match func_typ with
| None -> (Base (Condition), Pos.from_lpos $loc(_condition))
| None -> (Base (Condition), pos_condition)
| Some (arg_typ, arg_pos) ->
Func {
arg_typ = (Data arg_typ, arg_pos);
return_typ = (Condition, Pos.from_lpos $loc(_condition));
return_typ = (Condition, pos_condition);
}, Pos.from_lpos $sloc);
scope_decl_context_item_states = states;
}, Pos.from_lpos $sloc
}
}
let enum_decl_line :=
| ALT ; c = constructor ;
| ALT ; c = uident ;
t = option(preceded(CONTENT,addpos(typ))) ; {
{
enum_decl_case_name = c;
enum_decl_case_typ =
Option.map (fun (t, t_pos) -> Base (Data t), t_pos) t;
}, Pos.from_lpos $sloc
}
}
let constructor :=
| ~ = addpos(UIDENT) ; <>
let scope_use_condition :=
| UNDER_CONDITION ; e = expression ; <>
let code_item :=
| SCOPE ; c = constructor ;
e = option(scope_use_condition) ;
COLON ; items = nonempty_list(scope_item) ; {
(ScopeUse {
| SCOPE ; c = uident ;
e = option(preceded(UNDER_CONDITION,expression)) ;
COLON ; items = nonempty_list(addpos(scope_item)) ; {
ScopeUse {
scope_use_name = c;
scope_use_condition = e;
scope_use_items = items;
}, Pos.from_lpos $sloc)
}
}
| DECLARATION ; STRUCT ; c = constructor ;
COLON ; scopes = list(struct_scope) ; {
(StructDecl {
| DECLARATION ; STRUCT ; c = uident ;
COLON ; scopes = list(addpos(struct_scope)) ; {
StructDecl {
struct_decl_name = c;
struct_decl_fields = scopes;
}, Pos.from_lpos $sloc)
}
}
| DECLARATION ; SCOPE ; c = constructor ;
COLON ; context = nonempty_list(scope_decl_item) ; {
(ScopeDecl {
| DECLARATION ; SCOPE ; c = uident ;
COLON ; context = nonempty_list(addpos(scope_decl_item)) ; {
ScopeDecl {
scope_decl_name = c;
scope_decl_context = context;
}, Pos.from_lpos $sloc)
}
}
| DECLARATION ; ENUM ; c = constructor ;
COLON ; cases = list(enum_decl_line) ; {
(EnumDecl {
| DECLARATION ; ENUM ; c = uident ;
COLON ; cases = list(addpos(enum_decl_line)) ; {
EnumDecl {
enum_decl_name = c;
enum_decl_cases = cases;
}, Pos.from_lpos $sloc)
}
}
let code :=
| code = list(code_item) ; { (code, Pos.from_lpos $sloc) }
| code = list(addpos(code_item)) ; <>
let metadata_block :=
| BEGIN_METADATA ; option(law_text) ;
code_and_pos = code ;
~ = code ;
text = END_CODE ; {
let (code, _) = code_and_pos in
(code, (text, Pos.from_lpos $sloc))
(code, (text, Pos.from_lpos $sloc))
}
let law_heading :=
@ -623,9 +654,8 @@ let law_text :=
let source_file_item :=
| text = law_text ; { LawText text }
| BEGIN_CODE ;
code_and_pos = code ;
~ = code ;
text = END_CODE ; {
let (code, _) = code_and_pos in
CodeBlock (code, (text, Pos.from_lpos $sloc), false)
}
| heading = law_heading ; {

23
compiler/surface/print.ml
View File

@ -14,15 +14,22 @@
License for the specific language governing permissions and limitations under
the License. *)
open Catala_utils
open Ast
let format_primitive_typ (fmt : Format.formatter) (t : primitive_typ) : unit =
match t with
| Integer -> Format.fprintf fmt "integer"
| Decimal -> Format.fprintf fmt "decimal"
| Boolean -> Format.fprintf fmt "boolean"
| Money -> Format.fprintf fmt "money"
| Duration -> Format.fprintf fmt "duration"
| Text -> Format.fprintf fmt "text"
| Date -> Format.fprintf fmt "date"
| Named constructor -> Format.fprintf fmt "%s" constructor
| Integer -> Format.pp_print_string fmt "integer"
| Decimal -> Format.pp_print_string fmt "decimal"
| Boolean -> Format.pp_print_string fmt "boolean"
| Money -> Format.pp_print_string fmt "money"
| Duration -> Format.pp_print_string fmt "duration"
| Text -> Format.pp_print_string fmt "text"
| Date -> Format.pp_print_string fmt "date"
| Named (path, constructor) ->
Format.fprintf fmt "%a.%s"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.pp_print_char fmt '.')
(fun fmt (uid, _pos) -> Format.pp_print_string fmt uid))
path
(Marked.unmark constructor)

5
examples/aides_logement/prologue.catala_fr
View File

@ -341,8 +341,7 @@ champ d'application ÉligibilitéAidesPersonnelleLogement:
-- GardeAlternéeCoefficientPriseEnCharge de coeff: coeff
-- PasDeGardeAlternée: 0,0
))
pour personne_à_charge parmi (
personne_à_charge parmi personnes_à_charge_prises_en_compte
pour personne_à_charge parmi personnes_à_charge_prises_en_compte
tel que
(selon personne_à_charge sous forme
-- AutrePersonneÀCharge: faux
@ -350,7 +349,7 @@ champ d'application ÉligibilitéAidesPersonnelleLogement:
selon enfant.situation_garde_alternée sous forme
-- GardeAlternéeCoefficientPriseEnCharge: vrai
-- PasDeGardeAlternée: faux
))))
)))
```
### Éligibilité à l'aide personnalisée au logement