catala/compiler/shared_ast/operator.ml
2024-04-30 16:35:08 +02:00

579 lines
21 KiB
OCaml

(* This file is part of the Catala compiler, a specification language for tax
and social benefits computation rules. Copyright (C) 2020 Inria, contributor:
Louis Gesbert <louis.gesbert@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
open Catala_utils
open Definitions
include Definitions.Op
let name : type a. a t -> string = function
| Not -> "o_not"
| Length -> "o_length"
| GetDay -> "o_getDay"
| GetMonth -> "o_getMonth"
| GetYear -> "o_getYear"
| FirstDayOfMonth -> "o_firstDayOfMonth"
| LastDayOfMonth -> "o_lastDayOfMonth"
| Log _ -> "o_log"
| Minus -> "o_minus"
| Minus_int -> "o_minus_int"
| Minus_rat -> "o_minus_rat"
| Minus_mon -> "o_minus_mon"
| Minus_dur -> "o_minus_dur"
| ToRat -> "o_torat"
| ToRat_int -> "o_torat_int"
| ToRat_mon -> "o_torat_mon"
| ToMoney -> "o_tomoney"
| ToMoney_rat -> "o_tomoney_rat"
| Round -> "o_round"
| Round_rat -> "o_round_rat"
| Round_mon -> "o_round_mon"
| And -> "o_and"
| Or -> "o_or"
| Xor -> "o_xor"
| Eq -> "o_eq"
| Map -> "o_map"
| Map2 -> "o_map2"
| Concat -> "o_concat"
| Filter -> "o_filter"
| Reduce -> "o_reduce"
| Add -> "o_add"
| Add_int_int -> "o_add_int_int"
| Add_rat_rat -> "o_add_rat_rat"
| Add_mon_mon -> "o_add_mon_mon"
| Add_dat_dur rm -> begin
match rm with
| RoundUp -> "o_add_dat_dur RoundUp"
| RoundDown -> "o_add_dat_dur RoundDown"
| AbortOnRound -> "o_add_dat_dur AbortOnRound"
end
| Add_dur_dur -> "o_add_dur_dur"
| Sub -> "o_sub"
| Sub_int_int -> "o_sub_int_int"
| Sub_rat_rat -> "o_sub_rat_rat"
| Sub_mon_mon -> "o_sub_mon_mon"
| Sub_dat_dat -> "o_sub_dat_dat"
| Sub_dat_dur -> "o_sub_dat_dur"
| Sub_dur_dur -> "o_sub_dur_dur"
| Mult -> "o_mult"
| Mult_int_int -> "o_mult_int_int"
| Mult_rat_rat -> "o_mult_rat_rat"
| Mult_mon_rat -> "o_mult_mon_rat"
| Mult_dur_int -> "o_mult_dur_int"
| Div -> "o_div"
| Div_int_int -> "o_div_int_int"
| Div_rat_rat -> "o_div_rat_rat"
| Div_mon_mon -> "o_div_mon_mon"
| Div_mon_rat -> "o_div_mon_rat"
| Div_dur_dur -> "o_div_dur_dur"
| Lt -> "o_lt"
| Lt_int_int -> "o_lt_int_int"
| Lt_rat_rat -> "o_lt_rat_rat"
| Lt_mon_mon -> "o_lt_mon_mon"
| Lt_dur_dur -> "o_lt_dur_dur"
| Lt_dat_dat -> "o_lt_dat_dat"
| Lte -> "o_lte"
| Lte_int_int -> "o_lte_int_int"
| Lte_rat_rat -> "o_lte_rat_rat"
| Lte_mon_mon -> "o_lte_mon_mon"
| Lte_dur_dur -> "o_lte_dur_dur"
| Lte_dat_dat -> "o_lte_dat_dat"
| Gt -> "o_gt"
| Gt_int_int -> "o_gt_int_int"
| Gt_rat_rat -> "o_gt_rat_rat"
| Gt_mon_mon -> "o_gt_mon_mon"
| Gt_dur_dur -> "o_gt_dur_dur"
| Gt_dat_dat -> "o_gt_dat_dat"
| Gte -> "o_gte"
| Gte_int_int -> "o_gte_int_int"
| Gte_rat_rat -> "o_gte_rat_rat"
| Gte_mon_mon -> "o_gte_mon_mon"
| Gte_dur_dur -> "o_gte_dur_dur"
| Gte_dat_dat -> "o_gte_dat_dat"
| Eq_int_int -> "o_eq_int_int"
| Eq_rat_rat -> "o_eq_rat_rat"
| Eq_mon_mon -> "o_eq_mon_mon"
| Eq_dur_dur -> "o_eq_dur_dur"
| Eq_dat_dat -> "o_eq_dat_dat"
| Fold -> "o_fold"
| HandleDefault -> "o_handledefault"
| HandleDefaultOpt -> "o_handledefaultopt"
| ToClosureEnv -> "o_toclosureenv"
| FromClosureEnv -> "o_fromclosureenv"
let compare_log_entries l1 l2 =
match l1, l2 with
| VarDef t1, VarDef t2 ->
let tcompare =
Type.compare (t1.log_typ, Pos.no_pos) (t2.log_typ, Pos.no_pos)
in
if tcompare = 0 then
let ocompare = Bool.compare t1.log_io_output t2.log_io_output in
if ocompare = 0 then
match t1.log_io_input, t2.log_io_input with
| NoInput, NoInput | OnlyInput, OnlyInput | Reentrant, Reentrant -> 0
| NoInput, _ -> 1
| _, NoInput -> -1
| OnlyInput, _ -> 1
| _, OnlyInput -> -1
else ocompare
else tcompare
| BeginCall, BeginCall
| EndCall, EndCall
| PosRecordIfTrueBool, PosRecordIfTrueBool ->
0
| VarDef _, _ -> -1
| _, VarDef _ -> 1
| BeginCall, _ -> -1
| _, BeginCall -> 1
| EndCall, _ -> -1
| _, EndCall -> 1
| PosRecordIfTrueBool, _ -> .
| _, PosRecordIfTrueBool -> .
let compare (type a1 a2) (t1 : a1 t) (t2 : a2 t) =
match[@ocamlformat "disable"] t1, t2 with
| Log (l1, info1), Log (l2, info2) -> (
match compare_log_entries l1 l2 with
| 0 -> List.compare Uid.MarkedString.compare info1 info2
| n -> n)
| Add_dat_dur l, Add_dat_dur r -> Stdlib.compare l r
| Not, Not
| Length, Length
| GetDay, GetDay
| GetMonth, GetMonth
| GetYear, GetYear
| FirstDayOfMonth, FirstDayOfMonth
| LastDayOfMonth, LastDayOfMonth
| Minus, Minus
| Minus_int, Minus_int
| Minus_rat, Minus_rat
| Minus_mon, Minus_mon
| Minus_dur, Minus_dur
| ToRat, ToRat
| ToRat_int, ToRat_int
| ToRat_mon, ToRat_mon
| ToMoney, ToMoney
| ToMoney_rat, ToMoney_rat
| Round, Round
| Round_rat, Round_rat
| Round_mon, Round_mon
| And, And
| Or, Or
| Xor, Xor
| Eq, Eq
| Map, Map
| Map2, Map2
| Concat, Concat
| Filter, Filter
| Reduce, Reduce
| Add, Add
| Add_int_int, Add_int_int
| Add_rat_rat, Add_rat_rat
| Add_mon_mon, Add_mon_mon
| Add_dur_dur, Add_dur_dur
| Sub, Sub
| Sub_int_int, Sub_int_int
| Sub_rat_rat, Sub_rat_rat
| Sub_mon_mon, Sub_mon_mon
| Sub_dat_dat, Sub_dat_dat
| Sub_dat_dur, Sub_dat_dur
| Sub_dur_dur, Sub_dur_dur
| Mult, Mult
| Mult_int_int, Mult_int_int
| Mult_rat_rat, Mult_rat_rat
| Mult_mon_rat, Mult_mon_rat
| Mult_dur_int, Mult_dur_int
| Div, Div
| Div_int_int, Div_int_int
| Div_rat_rat, Div_rat_rat
| Div_mon_mon, Div_mon_mon
| Div_mon_rat, Div_mon_rat
| Div_dur_dur, Div_dur_dur
| Lt, Lt
| Lt_int_int, Lt_int_int
| Lt_rat_rat, Lt_rat_rat
| Lt_mon_mon, Lt_mon_mon
| Lt_dat_dat, Lt_dat_dat
| Lt_dur_dur, Lt_dur_dur
| Lte, Lte
| Lte_int_int, Lte_int_int
| Lte_rat_rat, Lte_rat_rat
| Lte_mon_mon, Lte_mon_mon
| Lte_dat_dat, Lte_dat_dat
| Lte_dur_dur, Lte_dur_dur
| Gt, Gt
| Gt_int_int, Gt_int_int
| Gt_rat_rat, Gt_rat_rat
| Gt_mon_mon, Gt_mon_mon
| Gt_dat_dat, Gt_dat_dat
| Gt_dur_dur, Gt_dur_dur
| Gte, Gte
| Gte_int_int, Gte_int_int
| Gte_rat_rat, Gte_rat_rat
| Gte_mon_mon, Gte_mon_mon
| Gte_dat_dat, Gte_dat_dat
| Gte_dur_dur, Gte_dur_dur
| Eq_int_int, Eq_int_int
| Eq_rat_rat, Eq_rat_rat
| Eq_mon_mon, Eq_mon_mon
| Eq_dat_dat, Eq_dat_dat
| Eq_dur_dur, Eq_dur_dur
| Fold, Fold
| HandleDefault, HandleDefault
| HandleDefaultOpt, HandleDefaultOpt
| FromClosureEnv, FromClosureEnv | ToClosureEnv, ToClosureEnv -> 0
| Not, _ -> -1 | _, Not -> 1
| Length, _ -> -1 | _, Length -> 1
| GetDay, _ -> -1 | _, GetDay -> 1
| GetMonth, _ -> -1 | _, GetMonth -> 1
| GetYear, _ -> -1 | _, GetYear -> 1
| FirstDayOfMonth, _ -> -1 | _, FirstDayOfMonth -> 1
| LastDayOfMonth, _ -> -1 | _, LastDayOfMonth -> 1
| Log _, _ -> -1 | _, Log _ -> 1
| Minus, _ -> -1 | _, Minus -> 1
| Minus_int, _ -> -1 | _, Minus_int -> 1
| Minus_rat, _ -> -1 | _, Minus_rat -> 1
| Minus_mon, _ -> -1 | _, Minus_mon -> 1
| Minus_dur, _ -> -1 | _, Minus_dur -> 1
| ToRat, _ -> -1 | _, ToRat -> 1
| ToRat_int, _ -> -1 | _, ToRat_int -> 1
| ToRat_mon, _ -> -1 | _, ToRat_mon -> 1
| ToMoney, _ -> -1 | _, ToMoney -> 1
| ToMoney_rat, _ -> -1 | _, ToMoney_rat -> 1
| Round, _ -> -1 | _, Round -> 1
| Round_rat, _ -> -1 | _, Round_rat -> 1
| Round_mon, _ -> -1 | _, Round_mon -> 1
| And, _ -> -1 | _, And -> 1
| Or, _ -> -1 | _, Or -> 1
| Xor, _ -> -1 | _, Xor -> 1
| Eq, _ -> -1 | _, Eq -> 1
| Map, _ -> -1 | _, Map -> 1
| Map2, _ -> -1 | _, Map2 -> 1
| Concat, _ -> -1 | _, Concat -> 1
| Filter, _ -> -1 | _, Filter -> 1
| Reduce, _ -> -1 | _, Reduce -> 1
| Add, _ -> -1 | _, Add -> 1
| Add_int_int, _ -> -1 | _, Add_int_int -> 1
| Add_rat_rat, _ -> -1 | _, Add_rat_rat -> 1
| Add_mon_mon, _ -> -1 | _, Add_mon_mon -> 1
| Add_dat_dur _, _ -> -1 | _, Add_dat_dur _ -> 1
| Add_dur_dur, _ -> -1 | _, Add_dur_dur -> 1
| Sub, _ -> -1 | _, Sub -> 1
| Sub_int_int, _ -> -1 | _, Sub_int_int -> 1
| Sub_rat_rat, _ -> -1 | _, Sub_rat_rat -> 1
| Sub_mon_mon, _ -> -1 | _, Sub_mon_mon -> 1
| Sub_dat_dat, _ -> -1 | _, Sub_dat_dat -> 1
| Sub_dat_dur, _ -> -1 | _, Sub_dat_dur -> 1
| Sub_dur_dur, _ -> -1 | _, Sub_dur_dur -> 1
| Mult, _ -> -1 | _, Mult -> 1
| Mult_int_int, _ -> -1 | _, Mult_int_int -> 1
| Mult_rat_rat, _ -> -1 | _, Mult_rat_rat -> 1
| Mult_mon_rat, _ -> -1 | _, Mult_mon_rat -> 1
| Mult_dur_int, _ -> -1 | _, Mult_dur_int -> 1
| Div, _ -> -1 | _, Div -> 1
| Div_int_int, _ -> -1 | _, Div_int_int -> 1
| Div_rat_rat, _ -> -1 | _, Div_rat_rat -> 1
| Div_mon_mon, _ -> -1 | _, Div_mon_mon -> 1
| Div_mon_rat, _ -> -1 | _, Div_mon_rat -> 1
| Div_dur_dur, _ -> -1 | _, Div_dur_dur -> 1
| Lt, _ -> -1 | _, Lt -> 1
| Lt_int_int, _ -> -1 | _, Lt_int_int -> 1
| Lt_rat_rat, _ -> -1 | _, Lt_rat_rat -> 1
| Lt_mon_mon, _ -> -1 | _, Lt_mon_mon -> 1
| Lt_dat_dat, _ -> -1 | _, Lt_dat_dat -> 1
| Lt_dur_dur, _ -> -1 | _, Lt_dur_dur -> 1
| Lte, _ -> -1 | _, Lte -> 1
| Lte_int_int, _ -> -1 | _, Lte_int_int -> 1
| Lte_rat_rat, _ -> -1 | _, Lte_rat_rat -> 1
| Lte_mon_mon, _ -> -1 | _, Lte_mon_mon -> 1
| Lte_dat_dat, _ -> -1 | _, Lte_dat_dat -> 1
| Lte_dur_dur, _ -> -1 | _, Lte_dur_dur -> 1
| Gt, _ -> -1 | _, Gt -> 1
| Gt_int_int, _ -> -1 | _, Gt_int_int -> 1
| Gt_rat_rat, _ -> -1 | _, Gt_rat_rat -> 1
| Gt_mon_mon, _ -> -1 | _, Gt_mon_mon -> 1
| Gt_dat_dat, _ -> -1 | _, Gt_dat_dat -> 1
| Gt_dur_dur, _ -> -1 | _, Gt_dur_dur -> 1
| Gte, _ -> -1 | _, Gte -> 1
| Gte_int_int, _ -> -1 | _, Gte_int_int -> 1
| Gte_rat_rat, _ -> -1 | _, Gte_rat_rat -> 1
| Gte_mon_mon, _ -> -1 | _, Gte_mon_mon -> 1
| Gte_dat_dat, _ -> -1 | _, Gte_dat_dat -> 1
| Gte_dur_dur, _ -> -1 | _, Gte_dur_dur -> 1
| Eq_int_int, _ -> -1 | _, Eq_int_int -> 1
| Eq_rat_rat, _ -> -1 | _, Eq_rat_rat -> 1
| Eq_mon_mon, _ -> -1 | _, Eq_mon_mon -> 1
| Eq_dat_dat, _ -> -1 | _, Eq_dat_dat -> 1
| Eq_dur_dur, _ -> -1 | _, Eq_dur_dur -> 1
| HandleDefault, _ -> -1 | _, HandleDefault -> 1
| HandleDefaultOpt, _ -> -1 | _, HandleDefaultOpt -> 1
| FromClosureEnv, _ -> -1 | _, FromClosureEnv -> 1
| ToClosureEnv, _ -> -1 | _, ToClosureEnv -> 1
| Fold, _ | _, Fold -> .
let equal t1 t2 = compare t1 t2 = 0
(* Classification of operators *)
let kind_dispatch :
type a.
polymorphic:(< polymorphic : yes ; .. > t Mark.pos -> 'b) ->
monomorphic:(< monomorphic : yes ; .. > t Mark.pos -> 'b) ->
?overloaded:(< overloaded : yes ; .. > t Mark.pos -> 'b) ->
?resolved:(< resolved : yes ; .. > t Mark.pos -> 'b) ->
a t Mark.pos ->
'b =
fun ~polymorphic ~monomorphic ?(overloaded = fun _ -> assert false)
?(resolved = fun _ -> assert false) op ->
match op with
| ( ( Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth
| And | Or | Xor ),
_ ) as op ->
monomorphic op
| ( ( Log _ | Length | Eq | Map | Map2 | Concat | Filter | Reduce | Fold
| HandleDefault | HandleDefaultOpt | FromClosureEnv | ToClosureEnv ),
_ ) as op ->
polymorphic op
| ( ( Minus | ToRat | ToMoney | Round | Add | Sub | Mult | Div | Lt | Lte | Gt
| Gte ),
_ ) as op ->
overloaded op
| ( ( Minus_int | Minus_rat | Minus_mon | Minus_dur | ToRat_int | ToRat_mon
| ToMoney_rat | Round_rat | Round_mon | Add_int_int | Add_rat_rat
| Add_mon_mon | Add_dat_dur _ | Add_dur_dur | Sub_int_int | Sub_rat_rat
| Sub_mon_mon | Sub_dat_dat | Sub_dat_dur | Sub_dur_dur | Mult_int_int
| Mult_rat_rat | Mult_mon_rat | Mult_dur_int | Div_int_int | Div_rat_rat
| Div_mon_mon | Div_mon_rat | Div_dur_dur | Lt_int_int | Lt_rat_rat
| Lt_mon_mon | Lt_dat_dat | Lt_dur_dur | Lte_int_int | Lte_rat_rat
| Lte_mon_mon | Lte_dat_dat | Lte_dur_dur | Gt_int_int | Gt_rat_rat
| Gt_mon_mon | Gt_dat_dat | Gt_dur_dur | Gte_int_int | Gte_rat_rat
| Gte_mon_mon | Gte_dat_dat | Gte_dur_dur | Eq_int_int | Eq_rat_rat
| Eq_mon_mon | Eq_dat_dat | Eq_dur_dur ),
_ ) as op ->
resolved op
type 'a no_overloads =
< overloaded : no
; monomorphic : yes
; polymorphic : yes
; resolved : yes
; .. >
as
'a
let translate (t : 'a no_overloads t Mark.pos) : 'b no_overloads t Mark.pos =
match t with
| ( ( Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth
| And | Or | Xor | HandleDefault | HandleDefaultOpt | Log _ | Length | Eq
| Map | Map2 | Concat | Filter | Reduce | Fold | Minus_int | Minus_rat
| Minus_mon | Minus_dur | ToRat_int | ToRat_mon | ToMoney_rat | Round_rat
| Round_mon | Add_int_int | Add_rat_rat | Add_mon_mon | Add_dat_dur _
| Add_dur_dur | Sub_int_int | Sub_rat_rat | Sub_mon_mon | Sub_dat_dat
| Sub_dat_dur | Sub_dur_dur | Mult_int_int | Mult_rat_rat | Mult_mon_rat
| Mult_dur_int | Div_int_int | Div_rat_rat | Div_mon_mon | Div_mon_rat
| Div_dur_dur | Lt_int_int | Lt_rat_rat | Lt_mon_mon | Lt_dat_dat
| Lt_dur_dur | Lte_int_int | Lte_rat_rat | Lte_mon_mon | Lte_dat_dat
| Lte_dur_dur | Gt_int_int | Gt_rat_rat | Gt_mon_mon | Gt_dat_dat
| Gt_dur_dur | Gte_int_int | Gte_rat_rat | Gte_mon_mon | Gte_dat_dat
| Gte_dur_dur | Eq_int_int | Eq_rat_rat | Eq_mon_mon | Eq_dat_dat
| Eq_dur_dur | FromClosureEnv | ToClosureEnv ),
_ ) as op ->
op
let monomorphic_type ((op : monomorphic t), pos) =
let args, ret =
match op with
| Not -> [TBool], TBool
| GetDay -> [TDate], TInt
| GetMonth -> [TDate], TInt
| GetYear -> [TDate], TInt
| FirstDayOfMonth -> [TDate], TDate
| LastDayOfMonth -> [TDate], TDate
| And -> [TBool; TBool], TBool
| Or -> [TBool; TBool], TBool
| Xor -> [TBool; TBool], TBool
in
TArrow (List.map (fun tau -> TLit tau, pos) args, (TLit ret, pos)), pos
(** Rules for overloads definitions:
- the concrete operator, including its return type, is uniquely determined
by the type of the operands
- no resolved version of an operator should be the redefinition of another
one with an added conversion. For example, [int + rat -> rat] is not
acceptable (that would amount to implicit casts).
These two points can be generalised for binary operators as: when
considering an operator with type ['a -> 'b -> 'c], for any given two among
['a], ['b] and ['c], there should be a unique solution for the third. *)
let resolved_type ((op : resolved t), pos) =
let args, ret =
match op with
| Minus_int -> [TInt], TInt
| Minus_rat -> [TRat], TRat
| Minus_mon -> [TMoney], TMoney
| Minus_dur -> [TDuration], TDuration
| ToRat_int -> [TInt], TRat
| ToRat_mon -> [TMoney], TRat
| ToMoney_rat -> [TRat], TMoney
| Round_rat -> [TRat], TRat
| Round_mon -> [TMoney], TMoney
| Add_int_int -> [TInt; TInt], TInt
| Add_rat_rat -> [TRat; TRat], TRat
| Add_mon_mon -> [TMoney; TMoney], TMoney
| Add_dat_dur _ -> [TDate; TDuration], TDate
| Add_dur_dur -> [TDuration; TDuration], TDuration
| Sub_int_int -> [TInt; TInt], TInt
| Sub_rat_rat -> [TRat; TRat], TRat
| Sub_mon_mon -> [TMoney; TMoney], TMoney
| Sub_dat_dat -> [TDate; TDate], TDuration
| Sub_dat_dur -> [TDate; TDuration], TDate
| Sub_dur_dur -> [TDuration; TDuration], TDuration
| Mult_int_int -> [TInt; TInt], TInt
| Mult_rat_rat -> [TRat; TRat], TRat
| Mult_mon_rat -> [TMoney; TRat], TMoney
| Mult_dur_int -> [TDuration; TInt], TDuration
| Div_int_int -> [TInt; TInt], TRat
| Div_rat_rat -> [TRat; TRat], TRat
| Div_mon_mon -> [TMoney; TMoney], TRat
| Div_mon_rat -> [TMoney; TRat], TMoney
| Div_dur_dur -> [TDuration; TDuration], TRat
| Lt_int_int -> [TInt; TInt], TBool
| Lt_rat_rat -> [TRat; TRat], TBool
| Lt_mon_mon -> [TMoney; TMoney], TBool
| Lt_dat_dat -> [TDate; TDate], TBool
| Lt_dur_dur -> [TDuration; TDuration], TBool
| Lte_int_int -> [TInt; TInt], TBool
| Lte_rat_rat -> [TRat; TRat], TBool
| Lte_mon_mon -> [TMoney; TMoney], TBool
| Lte_dat_dat -> [TDate; TDate], TBool
| Lte_dur_dur -> [TDuration; TDuration], TBool
| Gt_int_int -> [TInt; TInt], TBool
| Gt_rat_rat -> [TRat; TRat], TBool
| Gt_mon_mon -> [TMoney; TMoney], TBool
| Gt_dat_dat -> [TDate; TDate], TBool
| Gt_dur_dur -> [TDuration; TDuration], TBool
| Gte_int_int -> [TInt; TInt], TBool
| Gte_rat_rat -> [TRat; TRat], TBool
| Gte_mon_mon -> [TMoney; TMoney], TBool
| Gte_dat_dat -> [TDate; TDate], TBool
| Gte_dur_dur -> [TDuration; TDuration], TBool
| Eq_int_int -> [TInt; TInt], TBool
| Eq_rat_rat -> [TRat; TRat], TBool
| Eq_mon_mon -> [TMoney; TMoney], TBool
| Eq_dat_dat -> [TDate; TDate], TBool
| Eq_dur_dur -> [TDuration; TDuration], TBool
in
TArrow (List.map (fun tau -> TLit tau, pos) args, (TLit ret, pos)), pos
let resolve_overload_aux (op : overloaded t) (operands : typ_lit list) :
< resolved : yes ; .. > t * [ `Straight | `Reversed ] =
match op, operands with
| Minus, [TInt] -> Minus_int, `Straight
| Minus, [TRat] -> Minus_rat, `Straight
| Minus, [TMoney] -> Minus_mon, `Straight
| Minus, [TDuration] -> Minus_dur, `Straight
| ToRat, [TInt] -> ToRat_int, `Straight
| ToRat, [TMoney] -> ToRat_mon, `Straight
| ToMoney, [TRat] -> ToMoney_rat, `Straight
| Round, [TRat] -> Round_rat, `Straight
| Round, [TMoney] -> Round_mon, `Straight
| Add, [TInt; TInt] -> Add_int_int, `Straight
| Add, [TRat; TRat] -> Add_rat_rat, `Straight
| Add, [TMoney; TMoney] -> Add_mon_mon, `Straight
| Add, [TDuration; TDuration] -> Add_dur_dur, `Straight
| Add, [TDate; TDuration] -> Add_dat_dur AbortOnRound, `Straight
| Add, [TDuration; TDate] -> Add_dat_dur AbortOnRound, `Reversed
| Sub, [TInt; TInt] -> Sub_int_int, `Straight
| Sub, [TRat; TRat] -> Sub_rat_rat, `Straight
| Sub, [TMoney; TMoney] -> Sub_mon_mon, `Straight
| Sub, [TDuration; TDuration] -> Sub_dur_dur, `Straight
| Sub, [TDate; TDate] -> Sub_dat_dat, `Straight
| Sub, [TDate; TDuration] -> Sub_dat_dur, `Straight
| Mult, [TInt; TInt] -> Mult_int_int, `Straight
| Mult, [TRat; TRat] -> Mult_rat_rat, `Straight
| Mult, [TMoney; TRat] -> Mult_mon_rat, `Straight
| Mult, [TRat; TMoney] -> Mult_mon_rat, `Reversed
| Mult, [TDuration; TInt] -> Mult_dur_int, `Straight
| Mult, [TInt; TDuration] -> Mult_dur_int, `Reversed
| Div, [TInt; TInt] -> Div_int_int, `Straight
| Div, [TRat; TRat] -> Div_rat_rat, `Straight
| Div, [TMoney; TMoney] -> Div_mon_mon, `Straight
| Div, [TMoney; TRat] -> Div_mon_rat, `Straight
| Div, [TDuration; TDuration] -> Div_dur_dur, `Straight
| Lt, [TInt; TInt] -> Lt_int_int, `Straight
| Lt, [TRat; TRat] -> Lt_rat_rat, `Straight
| Lt, [TMoney; TMoney] -> Lt_mon_mon, `Straight
| Lt, [TDuration; TDuration] -> Lt_dur_dur, `Straight
| Lt, [TDate; TDate] -> Lt_dat_dat, `Straight
| Lte, [TInt; TInt] -> Lte_int_int, `Straight
| Lte, [TRat; TRat] -> Lte_rat_rat, `Straight
| Lte, [TMoney; TMoney] -> Lte_mon_mon, `Straight
| Lte, [TDuration; TDuration] -> Lte_dur_dur, `Straight
| Lte, [TDate; TDate] -> Lte_dat_dat, `Straight
| Gt, [TInt; TInt] -> Gt_int_int, `Straight
| Gt, [TRat; TRat] -> Gt_rat_rat, `Straight
| Gt, [TMoney; TMoney] -> Gt_mon_mon, `Straight
| Gt, [TDuration; TDuration] -> Gt_dur_dur, `Straight
| Gt, [TDate; TDate] -> Gt_dat_dat, `Straight
| Gte, [TInt; TInt] -> Gte_int_int, `Straight
| Gte, [TRat; TRat] -> Gte_rat_rat, `Straight
| Gte, [TMoney; TMoney] -> Gte_mon_mon, `Straight
| Gte, [TDuration; TDuration] -> Gte_dur_dur, `Straight
| Gte, [TDate; TDate] -> Gte_dat_dat, `Straight
| ( ( Minus | ToRat | ToMoney | Round | Add | Sub | Mult | Div | Lt | Lte | Gt
| Gte ),
_ ) ->
raise Not_found
let resolve_overload
ctx
((op, pos) : overloaded t Mark.pos)
(operands : typ list) :
< resolved : yes ; .. > t Mark.pos * [ `Straight | `Reversed ] =
try
let operands =
List.map
(fun t ->
match Mark.remove t with TLit tl -> tl | _ -> raise Not_found)
operands
in
let op, direction = resolve_overload_aux op operands in
(op, pos), direction
with Not_found ->
Message.error
~extra_pos:
(("", pos)
:: List.map
(fun ty ->
( Format.asprintf "Type %a coming from expression:"
(Print.typ ctx) ty,
Mark.get ty ))
operands)
"I don't know how to apply operator %a on types %a"
(Print.operator ~debug:true)
op
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf " and@ ")
(Print.typ ctx))
operands
let overload_type ctx (op : overloaded t Mark.pos) (operands : typ list) : typ =
let rop = fst (resolve_overload ctx op operands) in
resolved_type rop