diff --git a/Makefile b/Makefile index 9e784a0a..1065c56d 100644 --- a/Makefile +++ b/Makefile @@ -23,7 +23,8 @@ install-dependencies-ocaml: unionfind \ bindlib \ zarith \ - ocamlgraph + ocamlgraph \ + odate init-submodules: git submodule update --init diff --git a/src/catala/catala_surface/ast.ml b/src/catala/catala_surface/ast.ml index 13344a56..17e09c36 100644 --- a/src/catala/catala_surface/ast.ml +++ b/src/catala/catala_surface/ast.ml @@ -20,7 +20,15 @@ type ident = string type qident = ident Pos.marked list -type primitive_typ = Integer | Decimal | Boolean | Money | Text | Date | Named of constructor +type primitive_typ = + | Integer + | Decimal + | Boolean + | Money + | Duration + | Text + | Date + | Named of constructor type base_typ_data = | Primitive of primitive_typ @@ -55,7 +63,7 @@ type enum_decl = { type match_case_pattern = constructor Pos.marked list * ident Pos.marked option -type op_kind = KInt | KDec | KMoney +type op_kind = KInt | KDec | KMoney | KDate | KDuration type binop = | And diff --git a/src/catala/catala_surface/desugaring.ml b/src/catala/catala_surface/desugaring.ml index 24f99569..9a587ea3 100644 --- a/src/catala/catala_surface/desugaring.ml +++ b/src/catala/catala_surface/desugaring.ml @@ -20,7 +20,12 @@ module Cli = Utils.Cli a redefinition of a subvariable *) let translate_op_kind (k : Ast.op_kind) : Dcalc.Ast.op_kind = - match k with KInt -> KInt | KDec -> KRat | KMoney -> KMoney + match k with + | KInt -> KInt + | KDec -> KRat + | KMoney -> KMoney + | KDate -> KDate + | KDuration -> KDuration let translate_binop (op : Ast.binop) : Dcalc.Ast.binop = match op with @@ -88,7 +93,24 @@ let rec translate_expr (scope : Scopelang.Ast.ScopeName.t) | MoneyAmount i -> Scopelang.Ast.ELit (Dcalc.Ast.LMoney Z.((i.money_amount_units * of_int 100) + i.money_amount_cents)) - | _ -> Name_resolution.raise_unsupported_feature "literal" pos + | Number ((Int _, _), Some ((Year | Month | Day), _)) + | Number ((Dec (_, _), _), Some ((Year | Month | Day), _)) -> + Name_resolution.raise_unsupported_feature "literal" pos + | Date date -> ( + let date = + ODate.Unix.make + ~year:(Pos.unmark date.literal_date_year) + ~day:(Pos.unmark date.literal_date_day) + ~month: + ( try ODate.Month.of_int (Pos.unmark date.literal_date_month) + with Failure _ -> + Errors.raise_spanned_error "Invalid month (should be between 1 and 12)" + (Pos.get_position date.literal_date_month) ) + () + in + match ODate.Unix.some_if_valid date with + | Some date -> Scopelang.Ast.ELit (Dcalc.Ast.LDate date) + | None -> Errors.raise_spanned_error "Invalid date" pos ) in Bindlib.box (untyped_term, pos) | Ident x -> ( diff --git a/src/catala/catala_surface/dune b/src/catala/catala_surface/dune index 08ae8ac0..ac5827ac 100644 --- a/src/catala/catala_surface/dune +++ b/src/catala/catala_surface/dune @@ -1,6 +1,6 @@ (library (name surface) - (libraries utils menhirLib sedlex re desugared scopelang zarith) + (libraries utils menhirLib sedlex re desugared scopelang zarith odate) (public_name catala.surface) (preprocess (pps sedlex.ppx))) diff --git a/src/catala/catala_surface/lexer.ml b/src/catala/catala_surface/lexer.ml index d2924021..fb90b30b 100644 --- a/src/catala/catala_surface/lexer.ml +++ b/src/catala/catala_surface/lexer.ml @@ -69,6 +69,7 @@ let token_list : (string * token) list = ("text", TEXT); ("decimal", DECIMAL); ("date", DATE); + ("duration", DURATION); ("boolean", BOOLEAN); ("sum", SUM); ("ok", FILLED); @@ -167,6 +168,9 @@ let rec lex_code (lexbuf : lexbuf) : token = | "date" -> update_acc lexbuf; DATE + | "duration" -> + update_acc lexbuf; + DURATION | "bool" -> update_acc lexbuf; BOOLEAN @@ -301,6 +305,42 @@ let rec lex_code (lexbuf : lexbuf) : token = | "->" -> update_acc lexbuf; ARROW + | "<=@" -> + update_acc lexbuf; + LESSER_EQUAL_DATE + | "<@" -> + update_acc lexbuf; + LESSER_DATE + | ">=@" -> + update_acc lexbuf; + GREATER_EQUAL_DATE + | ">@" -> + update_acc lexbuf; + GREATER_DATE + | "-@" -> + update_acc lexbuf; + MINUSDATE + | "+@" -> + update_acc lexbuf; + PLUSDATE + | "<=^" -> + update_acc lexbuf; + LESSER_EQUAL_DURATION + | "<^" -> + update_acc lexbuf; + LESSER_DURATION + | ">=^" -> + update_acc lexbuf; + GREATER_EQUAL_DURATION + | ">^" -> + update_acc lexbuf; + GREATER_DURATION + | "+^" -> + update_acc lexbuf; + PLUSDURATION + | "-^" -> + update_acc lexbuf; + MINUSDURATION | "<=", 0x24 -> update_acc lexbuf; LESSER_EQUAL_MONEY diff --git a/src/catala/catala_surface/lexer_en.ml b/src/catala/catala_surface/lexer_en.ml index 37d29876..bbd03c79 100644 --- a/src/catala/catala_surface/lexer_en.ml +++ b/src/catala/catala_surface/lexer_en.ml @@ -37,6 +37,7 @@ let token_list_en : (string * token) list = ("text", TEXT); ("decimal", DECIMAL); ("date", DATE); + ("duration", DURATION); ("boolean", BOOLEAN); ("sum", SUM); ("fulfilled", FILLED); @@ -135,6 +136,9 @@ let rec lex_code_en (lexbuf : lexbuf) : token = | "date" -> L.update_acc lexbuf; DATE + | "duration" -> + L.update_acc lexbuf; + DURATION | "boolean" -> L.update_acc lexbuf; BOOLEAN @@ -269,6 +273,42 @@ let rec lex_code_en (lexbuf : lexbuf) : token = | "->" -> L.update_acc lexbuf; ARROW + | "<=@" -> + L.update_acc lexbuf; + LESSER_EQUAL_DATE + | "<@" -> + L.update_acc lexbuf; + LESSER_DATE + | ">=@" -> + L.update_acc lexbuf; + GREATER_EQUAL_DATE + | ">@" -> + L.update_acc lexbuf; + GREATER_DATE + | "-@" -> + L.update_acc lexbuf; + MINUSDATE + | "+@" -> + L.update_acc lexbuf; + PLUSDATE + | "<=^" -> + L.update_acc lexbuf; + LESSER_EQUAL_DURATION + | "<^" -> + L.update_acc lexbuf; + LESSER_DURATION + | ">=^" -> + L.update_acc lexbuf; + GREATER_EQUAL_DURATION + | ">^" -> + L.update_acc lexbuf; + GREATER_DURATION + | "+^" -> + L.update_acc lexbuf; + PLUSDURATION + | "-^" -> + L.update_acc lexbuf; + MINUSDURATION | "<=", 0x24 -> L.update_acc lexbuf; LESSER_EQUAL_MONEY diff --git a/src/catala/catala_surface/lexer_fr.ml b/src/catala/catala_surface/lexer_fr.ml index a41b5ea5..5bd2ab84 100644 --- a/src/catala/catala_surface/lexer_fr.ml +++ b/src/catala/catala_surface/lexer_fr.ml @@ -37,6 +37,7 @@ let token_list_fr : (string * token) list = ("texte", TEXT); ("decimal", DECIMAL); ("date", DATE); + ("durée", DURATION); ("booléen", BOOLEAN); ("somme", SUM); ("rempli", FILLED); @@ -136,6 +137,9 @@ let rec lex_code_fr (lexbuf : lexbuf) : token = | "date" -> L.update_acc lexbuf; DATE + | "dur", 0xE9, "e" -> + L.update_acc lexbuf; + DURATION | "bool", 0xE9, "en" -> L.update_acc lexbuf; BOOLEAN @@ -278,6 +282,42 @@ let rec lex_code_fr (lexbuf : lexbuf) : token = | "->" -> L.update_acc lexbuf; ARROW + | "<=@" -> + L.update_acc lexbuf; + LESSER_EQUAL_DATE + | "<@" -> + L.update_acc lexbuf; + LESSER_DATE + | ">=@" -> + L.update_acc lexbuf; + GREATER_EQUAL_DATE + | ">@" -> + L.update_acc lexbuf; + GREATER_DATE + | "-@" -> + L.update_acc lexbuf; + MINUSDATE + | "+@" -> + L.update_acc lexbuf; + PLUSDATE + | "<=^" -> + L.update_acc lexbuf; + LESSER_EQUAL_DURATION + | "<^" -> + L.update_acc lexbuf; + LESSER_DURATION + | ">=^" -> + L.update_acc lexbuf; + GREATER_EQUAL_DURATION + | ">^" -> + L.update_acc lexbuf; + GREATER_DURATION + | "+^" -> + L.update_acc lexbuf; + PLUSDURATION + | "-^" -> + L.update_acc lexbuf; + MINUSDURATION | "<=", 0x20AC -> L.update_acc lexbuf; LESSER_EQUAL_MONEY diff --git a/src/catala/catala_surface/name_resolution.ml b/src/catala/catala_surface/name_resolution.ml index 319d2c48..9bd78d63 100644 --- a/src/catala/catala_surface/name_resolution.ml +++ b/src/catala/catala_surface/name_resolution.ml @@ -104,7 +104,8 @@ let process_base_typ (ctxt : context) ((typ, typ_pos) : Ast.base_typ Pos.marked) | Ast.Integer -> (Scopelang.Ast.TLit TInt, typ_pos) | Ast.Decimal -> (Scopelang.Ast.TLit TRat, typ_pos) | Ast.Money -> (Scopelang.Ast.TLit TMoney, typ_pos) - | Ast.Date -> raise_unsupported_feature "date type" typ_pos + | Ast.Duration -> (Scopelang.Ast.TLit TDuration, typ_pos) + | Ast.Date -> (Scopelang.Ast.TLit TDate, typ_pos) | Ast.Boolean -> (Scopelang.Ast.TLit TBool, typ_pos) | Ast.Text -> raise_unsupported_feature "text type" typ_pos | Ast.Named ident -> ( diff --git a/src/catala/catala_surface/parser.mly b/src/catala/catala_surface/parser.mly index 605b0449..f9abd4c9 100644 --- a/src/catala/catala_surface/parser.mly +++ b/src/catala/catala_surface/parser.mly @@ -45,15 +45,18 @@ %token LESSER GREATER LESSER_EQUAL GREATER_EQUAL %token LESSER_DEC GREATER_DEC LESSER_EQUAL_DEC GREATER_EQUAL_DEC %token LESSER_MONEY GREATER_MONEY LESSER_EQUAL_MONEY GREATER_EQUAL_MONEY +%token LESSER_DATE GREATER_DATE LESSER_EQUAL_DATE GREATER_EQUAL_DATE +%token LESSER_DURATION GREATER_DURATION LESSER_EQUAL_DURATION GREATER_EQUAL_DURATION %token EXISTS IN SUCH THAT NOW %token DOT AND OR LPAREN RPAREN OPTIONAL EQUAL %token CARDINAL ASSERTION FIXED BY YEAR %token PLUS MINUS MULT DIV %token PLUSDEC MINUSDEC MULTDEC DIVDEC %token PLUSMONEY MINUSMONEY MULTMONEY DIVMONEY +%token MINUSDATE PLUSDATE PLUSDURATION MINUSDURATION %token MATCH WITH VARIES WITH_V %token FOR ALL WE_HAVE INCREASING DECREASING -%token NOT BOOLEAN PERCENT ARROW +%token NOT BOOLEAN PERCENT ARROW DURATION %token SCOPE FILLED NOT_EQUAL DEFINITION %token STRUCT CONTENT IF THEN DEPENDS DECLARATION %token CONTEXT ENUM ELSE DATE SUM @@ -70,6 +73,7 @@ typ_base: | INTEGER { (Integer, $sloc) } | BOOLEAN { (Boolean, $sloc) } | MONEY { (Money, $sloc) } +| DURATION { (Duration, $sloc) } | TEXT { (Text, $sloc) } | DECIMAL { (Decimal, $sloc) } | DATE { (Date, $sloc) } @@ -194,6 +198,14 @@ compare_op: | LESSER_EQUAL_MONEY { (Lte KMoney, $sloc) } | GREATER_MONEY { (Gt KMoney, $sloc) } | GREATER_EQUAL_MONEY { (Gte KMoney, $sloc) } +| LESSER_DATE { (Lt KDate, $sloc) } +| LESSER_EQUAL_DATE { (Lte KDate, $sloc) } +| GREATER_DATE { (Gt KDate, $sloc) } +| GREATER_EQUAL_DATE { (Gte KDate, $sloc) } +| LESSER_DURATION { (Lt KDuration, $sloc) } +| LESSER_EQUAL_DURATION { (Lte KDuration, $sloc) } +| GREATER_DURATION { (Gt KDuration, $sloc) } +| GREATER_EQUAL_DURATION { (Gte KDuration, $sloc) } | EQUAL { (Eq, $sloc) } | NOT_EQUAL { (Neq, $sloc) } @@ -235,6 +247,10 @@ mult_expression: } sum_op: +| PLUSDURATION { (Add KDuration, $sloc) } +| MINUSDURATION { (Sub KDuration, $sloc) } +| PLUSDATE { (Add KDate, $sloc) } +| MINUSDATE { (Sub KDate, $sloc) } | PLUSMONEY { (Add KMoney, $sloc) } | MINUSMONEY { (Sub KMoney, $sloc) } | PLUSDEC { (Add KDec, $sloc) } @@ -246,6 +262,7 @@ sum_unop: | MINUS { (Minus KInt, $sloc) } | MINUSDEC { (Minus KDec, $sloc) } | MINUSMONEY { (Minus KMoney, $sloc) } +| MINUSDURATION { (Minus KDuration, $sloc) } sum_expression: | e = mult_expression { e } diff --git a/src/catala/default_calculus/ast.ml b/src/catala/default_calculus/ast.ml index 6e151810..293903a2 100644 --- a/src/catala/default_calculus/ast.ml +++ b/src/catala/default_calculus/ast.ml @@ -15,7 +15,7 @@ module Pos = Utils.Pos module Uid = Utils.Uid -type typ_lit = TBool | TUnit | TInt | TRat | TMoney +type typ_lit = TBool | TUnit | TInt | TRat | TMoney | TDate | TDuration type typ = | TLit of typ_lit @@ -23,9 +23,26 @@ type typ = | TEnum of typ Pos.marked list | TArrow of typ Pos.marked * typ Pos.marked -type lit = LBool of bool | LEmptyError | LInt of Z.t | LRat of Q.t | LMoney of Z.t | LUnit +type date = ODate.Unix.t -type op_kind = KInt | KRat | KMoney +type duration = ODate.Unix.d + +type lit = + | LBool of bool + | LEmptyError + | LInt of Z.t + | LRat of Q.t + | LMoney of Z.t + | LUnit + | LDate of date + | LDuration of duration + +type op_kind = + | KInt + | KRat + | KMoney + | KDate + | KDuration (** All ops don't have a Kdate and KDuration *) type binop = | And diff --git a/src/catala/default_calculus/dune b/src/catala/default_calculus/dune index 2ec7c591..ff9f00da 100644 --- a/src/catala/default_calculus/dune +++ b/src/catala/default_calculus/dune @@ -1,7 +1,7 @@ (library (name dcalc) (public_name catala.dcalc) - (libraries bindlib unionFind utils zarith)) + (libraries bindlib unionFind utils zarith odate)) (documentation (package catala)) diff --git a/src/catala/default_calculus/interpreter.ml b/src/catala/default_calculus/interpreter.ml index d3eabab1..48be0686 100644 --- a/src/catala/default_calculus/interpreter.ml +++ b/src/catala/default_calculus/interpreter.ml @@ -68,6 +68,14 @@ let evaluate_operator (op : A.operator Pos.marked) (args : A.expr Pos.marked lis (Some "The division operator:", Pos.get_position op); (Some "The null denominator:", Pos.get_position (List.nth args 2)); ] + | A.Binop (A.Add KDuration), [ ELit (LDuration i1); ELit (LDuration i2) ] -> + A.ELit (LDuration (ODuration.( + ) i1 i2)) + | A.Binop (A.Sub KDuration), [ ELit (LDuration i1); ELit (LDuration i2) ] -> + A.ELit (LDuration (ODuration.( - ) i1 i2)) + | A.Binop (A.Sub KDate), [ ELit (LDate i1); ELit (LDate i2) ] -> + A.ELit (LDuration (ODate.Unix.between i1 i2)) + | A.Binop (A.Add KDate), [ ELit (LDate i1); ELit (LDuration i2) ] -> + A.ELit (LDate (ODate.Unix.move i1 i2)) | A.Binop (A.Lt KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool (i1 < i2)) | A.Binop (A.Lte KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool (i1 <= i2)) | A.Binop (A.Gt KInt), [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool (i1 > i2)) @@ -76,10 +84,41 @@ let evaluate_operator (op : A.operator Pos.marked) (args : A.expr Pos.marked lis | A.Binop (A.Lte KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Q.(i1 <= i2)) | A.Binop (A.Gt KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Q.(i1 > i2)) | A.Binop (A.Gte KRat), [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Q.(i1 >= i2)) + | A.Binop (A.Lt KDuration), [ ELit (LDuration i1); ELit (LDuration i2) ] -> + let diff = ODuration.( - ) i2 i1 in + A.ELit (LBool (ODuration.is_positive diff)) + | A.Binop (A.Lte KDuration), [ ELit (LDuration i1); ELit (LDuration i2) ] -> + let diff = ODuration.( - ) i2 i1 in + A.ELit (LBool (ODuration.is_positive diff || ODuration.is_instantenous diff)) + | A.Binop (A.Gt KDuration), [ ELit (LDuration i1); ELit (LDuration i2) ] -> + let diff = ODuration.( - ) i2 i1 in + A.ELit (LBool (ODuration.is_negative diff)) + | A.Binop (A.Gte KDuration), [ ELit (LDuration i1); ELit (LDuration i2) ] -> + let diff = ODuration.( - ) i2 i1 in + A.ELit (LBool (ODuration.is_negative diff || ODuration.is_instantenous diff)) + | A.Binop (A.Lt KDate), [ ELit (LDate i1); ELit (LDate i2) ] -> + A.ELit (LBool (ODate.Unix.compare i1 i2 < 0)) + | A.Binop (A.Lte KDate), [ ELit (LDate i1); ELit (LDate i2) ] -> + A.ELit (LBool (ODate.Unix.compare i1 i2 <= 0)) + | A.Binop (A.Gt KDate), [ ELit (LDate i1); ELit (LDate i2) ] -> + A.ELit (LBool (ODate.Unix.compare i1 i2 > 0)) + | A.Binop (A.Gte KDate), [ ELit (LDate i1); ELit (LDate i2) ] -> + A.ELit (LBool (ODate.Unix.compare i1 i2 >= 0)) + | A.Binop A.Eq, [ ELit (LDuration i1); ELit (LDuration i2) ] -> + let diff = ODuration.( - ) i2 i1 in + A.ELit (LBool (ODuration.is_instantenous diff)) + | A.Binop A.Eq, [ ELit (LDate i1); ELit (LDate i2) ] -> + A.ELit (LBool (ODate.Unix.compare i1 i2 = 0)) | A.Binop A.Eq, [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Q.(i1 = i2)) | A.Binop A.Eq, [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool (i1 = i2)) | A.Binop A.Eq, [ ELit (LBool b1); ELit (LBool b2) ] -> A.ELit (LBool (b1 = b2)) | A.Binop A.Eq, [ _; _ ] -> A.ELit (LBool false) (* comparing functions return false *) + | A.Binop A.Neq, [ ELit (LDuration i1); ELit (LDuration i2) ] -> + let diff = ODuration.( - ) i2 i1 in + A.ELit (LBool (not (ODuration.is_instantenous diff))) + | A.Binop A.Neq, [ ELit (LDate i1); ELit (LDate i2) ] -> + A.ELit (LBool (ODate.Unix.compare i1 i2 <> 0)) + | A.Binop A.Neq, [ ELit (LRat i1); ELit (LRat i2) ] -> A.ELit (LBool Q.(i1 <> i2)) | A.Binop A.Neq, [ ELit (LInt i1); ELit (LInt i2) ] -> A.ELit (LBool (i1 <> i2)) | A.Binop A.Neq, [ ELit (LBool b1); ELit (LBool b2) ] -> A.ELit (LBool (b1 <> b2)) | A.Binop A.Neq, [ _; _ ] -> A.ELit (LBool true) @@ -97,9 +136,11 @@ let evaluate_operator (op : A.operator Pos.marked) (args : A.expr Pos.marked lis | A.Unop _, [ ELit LEmptyError ] -> A.ELit LEmptyError | _ -> Errors.raise_multispanned_error - "operator applied to the wrong arguments (should not happen if the term was well-typed)" - [ (Some "Operator:", Pos.get_position op) ] - @@ List.mapi (fun i arg -> Some ("Argument n°" ^ string_of_int i, Pos.get_position arg)) ) + "Operator applied to the wrong arguments\n(should nothappen if the term was well-typed)" + ( [ (Some "Operator:", Pos.get_position op) ] + @ List.mapi + (fun i arg -> (Some ("Argument n°" ^ string_of_int (i + 1)), Pos.get_position arg)) + args ) ) op let rec evaluate_expr (e : A.expr Pos.marked) : A.expr Pos.marked = diff --git a/src/catala/default_calculus/print.ml b/src/catala/default_calculus/print.ml index 30b7c20f..a9448eeb 100644 --- a/src/catala/default_calculus/print.ml +++ b/src/catala/default_calculus/print.ml @@ -18,17 +18,23 @@ open Ast let typ_needs_parens (e : typ Pos.marked) : bool = match Pos.unmark e with TArrow _ -> true | _ -> false +let format_tlit (fmt : Format.formatter) (l : typ_lit) : unit = + match l with + | TUnit -> Format.fprintf fmt "unit" + | TBool -> Format.fprintf fmt "boolean" + | TInt -> Format.fprintf fmt "integer" + | TRat -> Format.fprintf fmt "decimal" + | TMoney -> Format.fprintf fmt "money" + | TDuration -> Format.fprintf fmt "duration" + | TDate -> Format.fprintf fmt "date" + let rec format_typ (fmt : Format.formatter) (typ : typ Pos.marked) : unit = let format_typ_with_parens (fmt : Format.formatter) (t : typ Pos.marked) = if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t else Format.fprintf fmt "%a" format_typ t in match Pos.unmark typ with - | TLit TUnit -> Format.fprintf fmt "unit" - | TLit TBool -> Format.fprintf fmt "boolean" - | TLit TInt -> Format.fprintf fmt "integer" - | TLit TRat -> Format.fprintf fmt "decimal" - | TLit TMoney -> Format.fprintf fmt "money" + | TLit l -> Format.fprintf fmt "%a" format_tlit l | TTuple ts -> Format.fprintf fmt "(%a)" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt " *@ ") format_typ) @@ -82,9 +88,18 @@ let format_lit (fmt : Format.formatter) (l : lit Pos.marked) : unit = ( if List.length !digits - leading_zeroes !digits = !Utils.Cli.max_prec_digits then "…" else "" ) | LMoney e -> Format.fprintf fmt "$%.2f" Q.(to_float (of_bigint e / of_int 100)) + | LDate d -> + Format.fprintf fmt "%s" + (ODate.Unix.To.string (Option.get (ODate.Unix.To.generate_printer "%Y-%m-%d")) d) + | LDuration d -> + Format.fprintf fmt "%s" + (ODuration.To.string + (Option.get (ODuration.To.generate_printer "[%Y] years or [%M] months of [%D] days")) + d) let format_op_kind (fmt : Format.formatter) (k : op_kind) = - Format.fprintf fmt "%s" (match k with KInt -> "" | KRat -> "." | KMoney -> "$") + Format.fprintf fmt "%s" + (match k with KInt -> "" | KRat -> "." | KMoney -> "$" | KDate -> "@" | KDuration -> "^") let format_binop (fmt : Format.formatter) (op : binop Pos.marked) : unit = match Pos.unmark op with diff --git a/src/catala/default_calculus/typing.ml b/src/catala/default_calculus/typing.ml index a51ecdfc..a83ff31e 100644 --- a/src/catala/default_calculus/typing.ml +++ b/src/catala/default_calculus/typing.ml @@ -30,11 +30,7 @@ type typ = let rec format_typ (fmt : Format.formatter) (ty : typ Pos.marked UnionFind.elem) : unit = let ty_repr = UnionFind.get (UnionFind.find ty) in match Pos.unmark ty_repr with - | TLit TUnit -> Format.fprintf fmt "unit" - | TLit TBool -> Format.fprintf fmt "bool" - | TLit TInt -> Format.fprintf fmt "int" - | TLit TRat -> Format.fprintf fmt "dec" - | TLit TMoney -> Format.fprintf fmt "money" + | TLit l -> Format.fprintf fmt "%a" Print.format_tlit l | TAny -> Format.fprintf fmt "any type" | TTuple ts -> Format.fprintf fmt "(%a)" @@ -52,9 +48,17 @@ let rec unify (t1 : typ Pos.marked UnionFind.elem) (t2 : typ Pos.marked UnionFin let t2_repr = UnionFind.get (UnionFind.find t2) in match (t1_repr, t2_repr) with | (TLit tl1, _), (TLit tl2, _) when tl1 = tl2 -> () - | (TArrow (t11, t12), _), (TArrow (t21, t22), _) -> - unify t11 t21; - unify t12 t22 + | (TArrow (t11, t12), t1_pos), (TArrow (t21, t22), t2_pos) -> ( + try + unify t11 t21; + unify t12 t22 + with Errors.StructuredError (msg, err_pos) -> + Errors.raise_multispanned_error msg + ( err_pos + @ [ + (Some (Format.asprintf "Type %a coming from expression:" format_typ t1), t1_pos); + (Some (Format.asprintf "Type %a coming from expression:" format_typ t2), t2_pos); + ] ) ) | (TTuple ts1, _), (TTuple ts2, _) -> List.iter2 unify ts1 ts2 | (TEnum ts1, _), (TEnum ts2, _) -> List.iter2 unify ts1 ts2 | (TAny, _), (TAny, _) -> ignore (UnionFind.union t1 t2) @@ -78,6 +82,8 @@ let op_type (op : A.operator Pos.marked) : typ Pos.marked UnionFind.elem = let it = UnionFind.make (TLit TInt, pos) in let rt = UnionFind.make (TLit TRat, pos) in let mt = UnionFind.make (TLit TMoney, pos) in + let dut = UnionFind.make (TLit TDuration, pos) in + let dat = UnionFind.make (TLit TDate, pos) in let any = UnionFind.make (TAny, pos) in let arr x y = UnionFind.make (TArrow (x, y), pos) in match Pos.unmark op with @@ -85,17 +91,26 @@ let op_type (op : A.operator Pos.marked) : typ Pos.marked UnionFind.elem = | A.Binop (A.Add KInt | A.Sub KInt | A.Mult KInt | A.Div KInt) -> arr it (arr it it) | A.Binop (A.Add KRat | A.Sub KRat | A.Mult KRat | A.Div KRat) -> arr rt (arr rt rt) | A.Binop (A.Add KMoney | A.Sub KMoney) -> arr mt (arr mt mt) + | A.Binop (A.Add KDuration | A.Sub KDuration) -> arr dut (arr dut dut) + | A.Binop (A.Sub KDate) -> arr dat (arr dat dut) + | A.Binop (A.Add KDate) -> arr dat (arr dut dat) | A.Binop (A.Div KMoney) -> arr mt (arr mt rt) | A.Binop (A.Mult KMoney) -> arr mt (arr rt mt) | A.Binop (A.Lt KInt | A.Lte KInt | A.Gt KInt | A.Gte KInt) -> arr it (arr it bt) | A.Binop (A.Lt KRat | A.Lte KRat | A.Gt KRat | A.Gte KRat) -> arr rt (arr rt bt) | A.Binop (A.Lt KMoney | A.Lte KMoney | A.Gt KMoney | A.Gte KMoney) -> arr mt (arr mt bt) + | A.Binop (A.Lt KDate | A.Lte KDate | A.Gt KDate | A.Gte KDate) -> arr dat (arr dat bt) + | A.Binop (A.Lt KDuration | A.Lte KDuration | A.Gt KDuration | A.Gte KDuration) -> + arr dut (arr dut bt) | A.Binop (A.Eq | A.Neq) -> arr any (arr any bt) | A.Unop (A.Minus KInt) -> arr it it | A.Unop (A.Minus KRat) -> arr rt rt | A.Unop (A.Minus KMoney) -> arr mt mt + | A.Unop (A.Minus KDuration) -> arr dut dut | A.Unop A.Not -> arr bt bt | A.Unop A.ErrorOnEmpty -> arr any any + | Binop (Mult (KDate | KDuration)) | Binop (Div (KDate | KDuration)) | Unop (Minus KDate) -> + Errors.raise_spanned_error "This operator is not available!" pos let rec ast_to_typ (ty : A.typ) : typ = match ty with @@ -133,6 +148,8 @@ let rec typecheck_expr_bottom_up (env : env) (e : A.expr Pos.marked) : typ Pos.m | ELit (LInt _) -> UnionFind.make (Pos.same_pos_as (TLit TInt) e) | ELit (LRat _) -> UnionFind.make (Pos.same_pos_as (TLit TRat) e) | ELit (LMoney _) -> UnionFind.make (Pos.same_pos_as (TLit TMoney) e) + | ELit (LDate _) -> UnionFind.make (Pos.same_pos_as (TLit TDate) e) + | ELit (LDuration _) -> UnionFind.make (Pos.same_pos_as (TLit TDuration) e) | ELit LUnit -> UnionFind.make (Pos.same_pos_as (TLit TUnit) e) | ELit LEmptyError -> UnionFind.make (Pos.same_pos_as TAny e) | ETuple es -> @@ -236,6 +253,8 @@ and typecheck_expr_top_down (env : env) (e : A.expr Pos.marked) | ELit (LInt _) -> unify tau (UnionFind.make (Pos.same_pos_as (TLit TInt) e)) | ELit (LRat _) -> unify tau (UnionFind.make (Pos.same_pos_as (TLit TRat) e)) | ELit (LMoney _) -> unify tau (UnionFind.make (Pos.same_pos_as (TLit TMoney) e)) + | ELit (LDate _) -> unify tau (UnionFind.make (Pos.same_pos_as (TLit TDate) e)) + | ELit (LDuration _) -> unify tau (UnionFind.make (Pos.same_pos_as (TLit TDuration) e)) | ELit LUnit -> unify tau (UnionFind.make (Pos.same_pos_as (TLit TUnit) e)) | ELit LEmptyError -> unify tau (UnionFind.make (Pos.same_pos_as TAny e)) | ETuple es -> ( diff --git a/src/catala/scope_language/print.ml b/src/catala/scope_language/print.ml index 393cfe4b..02a863ec 100644 --- a/src/catala/scope_language/print.ml +++ b/src/catala/scope_language/print.ml @@ -37,11 +37,7 @@ let rec format_typ (fmt : Format.formatter) (typ : typ Pos.marked) : unit = else Format.fprintf fmt "%a" format_typ t in match Pos.unmark typ with - | TLit TUnit -> Format.fprintf fmt "unit" - | TLit TBool -> Format.fprintf fmt "boolean" - | TLit TInt -> Format.fprintf fmt "integer" - | TLit TRat -> Format.fprintf fmt "decimal" - | TLit TMoney -> Format.fprintf fmt "money" + | TLit l -> Dcalc.Print.format_tlit fmt l | TStruct s -> Format.fprintf fmt "%a" Ast.StructName.format_t s | TEnum e -> Format.fprintf fmt "%a" Ast.EnumName.format_t e | TArrow (t1, t2) -> diff --git a/tests/test_date/simple.catala b/tests/test_date/simple.catala new file mode 100644 index 00000000..24ddec34 --- /dev/null +++ b/tests/test_date/simple.catala @@ -0,0 +1,13 @@ +@Article@ + +/* +new scope A: + param x content date + param y content date + param z content duration + +scope A: + def x := |01/01/2019| + def y := |30/09/2002| + def z := x -@ y +*/ \ No newline at end of file