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

Added date and durations handling

Browse Source
This commit is contained in:
Denis Merigoux 2020-12-10 11:35:56 +01:00
parent 0038a1ea2d
commit 902c3f8d7d
16 changed files with 304 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Makefile
View File

@ -23,7 +23,8 @@ install-dependencies-ocaml:
unionfind \
bindlib \
zarith \
ocamlgraph
ocamlgraph \
odate
init-submodules:
git submodule update --init

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

@ -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

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

@ -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 -> (

2
src/catala/catala_surface/dune
View File

@ -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)))

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

@ -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

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

@ -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

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

@ -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

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

@ -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 -> (

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

@ -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 }

23
src/catala/default_calculus/ast.ml
View File

@ -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

2
src/catala/default_calculus/dune
View File

@ -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))

47
src/catala/default_calculus/interpreter.ml
View File

@ -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 =

27
src/catala/default_calculus/print.ml
View File

@ -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

35
src/catala/default_calculus/typing.ml
View File

@ -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 -> (

6
src/catala/scope_language/print.ml
View File

@ -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) ->

13
tests/test_date/simple.catala Normal file
View File

@ -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
*/