catala/compiler/shared_ast/operator.ml

(* 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 k. (a, k) 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"
  | 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 -> "o_add_dat_dur"
  | 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_mon"
  | 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"

let compare_log_entries l1 l2 =
  match l1, l2 with
  | VarDef t1, VarDef t2 -> Type.compare (t1, Pos.no_pos) (t2, Pos.no_pos)
  | BeginCall, BeginCall
  | EndCall, EndCall
  | PosRecordIfTrueBool, PosRecordIfTrueBool ->
    0
  | VarDef _, _ -> -1
  | _, VarDef _ -> 1
  | BeginCall, _ -> -1
  | _, BeginCall -> 1
  | EndCall, _ -> -1
  | _, EndCall -> 1
  | PosRecordIfTrueBool, _ -> .
  | _, PosRecordIfTrueBool -> .

let compare (type a k a2 k2) (t1 : (a, k) t) (t2 : (a2, k2) 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)
  | 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
  | 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_dat_dur, Add_dat_dur
  | 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 -> 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
  | 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
  | Fold, _  | _, Fold -> .

let equal (type a k a2 k2) (t1 : (a, k) t) (t2 : (a2, k2) t) = compare t1 t2 = 0

(* Classification of operators *)

let kind_dispatch :
    type a b k.
    polymorphic:((_, polymorphic) t -> b) ->
    monomorphic:((_, monomorphic) t -> b) ->
    ?overloaded:((_, overloaded) t -> b) ->
    ?resolved:((_, resolved) t -> b) ->
    (a, k) t ->
    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 | Concat | Filter | Reduce | Fold) 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

(* Glorified identity... allowed operators are the same in scopelang, dcalc,
   lcalc *)
let translate :
    type k.
    ([< scopelang | dcalc | lcalc ], k) t ->
    ([< scopelang | dcalc | lcalc ], k) t =
 fun op ->
  match op with
  | Length -> Length
  | Log (i, l) -> Log (i, l)
  | Eq -> Eq
  | Map -> Map
  | Concat -> Concat
  | Filter -> Filter
  | Reduce -> Reduce
  | Fold -> Fold
  | Not -> Not
  | GetDay -> GetDay
  | GetMonth -> GetMonth
  | GetYear -> GetYear
  | FirstDayOfMonth -> FirstDayOfMonth
  | LastDayOfMonth -> LastDayOfMonth
  | And -> And
  | Or -> Or
  | Xor -> Xor
  | Minus_int -> Minus_int
  | Minus_rat -> Minus_rat
  | Minus_mon -> Minus_mon
  | Minus_dur -> Minus_dur
  | ToRat_int -> ToRat_int
  | ToRat_mon -> ToRat_mon
  | ToMoney_rat -> ToMoney_rat
  | Round_rat -> Round_rat
  | Round_mon -> Round_mon
  | Add_int_int -> Add_int_int
  | Add_rat_rat -> Add_rat_rat
  | Add_mon_mon -> Add_mon_mon
  | Add_dat_dur -> Add_dat_dur
  | Add_dur_dur -> Add_dur_dur
  | 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_int_int -> Mult_int_int
  | Mult_rat_rat -> Mult_rat_rat
  | Mult_mon_rat -> Mult_mon_rat
  | Mult_dur_int -> Mult_dur_int
  | 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_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_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_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_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

let monomorphic_type (op, 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, 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], TDuration
    | 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 : ('a, overloaded) t) (operands : typ_lit list) :
    ('b, resolved) 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, `Straight
  | Add, [TDuration; TDate] -> Add_dat_dur, `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 : ('a, overloaded) t Marked.pos)
    (operands : typ list) : ('b, resolved) t * [ `Straight | `Reversed ] =
  try
    let operands =
      List.map
        (fun t ->
          match Marked.unmark t with TLit tl -> tl | _ -> raise Not_found)
        operands
    in
    resolve_overload_aux (Marked.unmark op) operands
  with Not_found ->
    Errors.raise_multispanned_error
      ((None, Marked.get_mark op)
      :: List.map
           (fun ty ->
             ( Some
                 (Format.asprintf "Type %a coming from expression:"
                    (Print.typ ctx) ty),
               Marked.get_mark ty ))
           operands)
      "I don't know how to apply operator %a on types %a" Print.operator
      (Marked.unmark op)
      (Format.pp_print_list
         ~pp_sep:(fun ppf () -> Format.fprintf ppf " and@ ")
         (Print.typ ctx))
      operands

let overload_type ctx (op : ('a, overloaded) t Marked.pos) (operands : typ list)
    : typ =
  let rop = fst (resolve_overload ctx op operands) in
  resolved_type (Marked.same_mark_as rop op)