- [x] shared_ast

2024-09-19 16:28:12 +03:00 · 2023-01-12 15:12:11 +01:00 · 2023-01-12 15:12:11 +01:00 · f2bebe613b
commit f2bebe613b
parent d79b8463a6
4 changed files with 84 additions and 87 deletions
--- a/compiler/shared_ast/expr.ml
+++ b/compiler/shared_ast/expr.ml
@ -182,7 +182,7 @@ let fold_marks
  | [] -> invalid_arg "Dcalc.Ast.fold_mark"
  | Untyped _ :: _ as ms ->
    Untyped { pos = pos_f (List.map (function Untyped { pos } -> pos) ms) }
-  | Typed _ :: _ ->
+  | Typed _ :: _ as ms ->
    Typed
      {
        pos = pos_f (List.map (function Typed { pos; _ } -> pos) ms);
@ -713,34 +713,28 @@ let make_abs xs e taus pos =
  let mark =
    map_mark
      (fun _ -> pos)
-      (fun ety ->
-        List.fold_right
-          (fun tx acc -> Marked.mark pos (TArrow (tx, acc)))
-          taus ety)
+      (fun ety -> Marked.mark pos (TArrow (taus, ety)))
      (Marked.get_mark e)
  in
  eabs (bind xs e) taus mark

-let make_app e u pos =
+let make_app e args pos =
  let mark =
    fold_marks
      (fun _ -> pos)
      (function
        | [] -> assert false
-        | fty :: argtys ->
-          List.fold_left
-            (fun tf tx ->
-              match Marked.unmark tf with
-              | TArrow (tx', tr) ->
-                assert (Type.unifiable tx.ty tx');
-                (* wrong arg type *)
-                tr
-              | TAny -> tf
-              | _ -> assert false)
-            fty.ty argtys)
-      (List.map Marked.get_mark (e :: u))
+        | fty :: argtys -> (
+          match Marked.unmark fty.ty with
+          | TArrow (tx', tr) ->
+            assert (
+              argtys |> List.map (fun x -> x.ty) |> Type.unifiable_list tx');
+            tr
+          | TAny -> fty.ty
+          | _ -> assert false))
+      (List.map Marked.get_mark (e :: args))
  in
-  eapp e u mark
+  eapp e args mark

 let empty_thunked_term mark =
  let silent = Var.make "_" in
--- a/compiler/shared_ast/operator.ml
+++ b/compiler/shared_ast/operator.ml
@ -404,18 +404,19 @@ let translate :
  | Eq_dur_dur -> Eq_dur_dur

 let monomorphic_type (op, pos) =
-  let ( @- ) a b = TArrow ((TLit a, pos), b), pos in
-  let ( @-> ) a b = TArrow ((TLit a, pos), (TLit b, pos)), pos in
+  let ( @-> ) a b =
+    TArrow (List.map (fun tau -> TLit tau, pos) a, (TLit b, pos)), pos
+  in
  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
+  | 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

 (** Rules for overloads definitions:

@ -431,62 +432,63 @@ let monomorphic_type (op, pos) =
    ['a], ['b] and ['c], there should be a unique solution for the third. *)

 let resolved_type (op, pos) =
-  let ( @- ) a b = TArrow ((TLit a, pos), b), pos in
-  let ( @-> ) a b = TArrow ((TLit a, pos), (TLit b, pos)), pos in
+  let ( @-> ) a b =
+    TArrow (List.map (fun tau -> TLit tau, pos) a, (TLit b, pos)), pos
+  in
  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
-  | 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
+  | 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
+  | 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

 let resolve_overload_aux (op : ('a, overloaded) t) (operands : typ_lit list) :
    ('b, resolved) t * [ `Straight | `Reversed ] =
--- a/compiler/shared_ast/scope.ml
+++ b/compiler/shared_ast/scope.ml
@ -155,7 +155,7 @@ let build_typ_from_sig
    (pos : Pos.t) : typ =
  let input_typ = Marked.mark pos (TStruct scope_input_struct_name) in
  let result_typ = Marked.mark pos (TStruct scope_return_struct_name) in
-  Marked.mark pos (TArrow (input_typ, result_typ))
+  Marked.mark pos (TArrow ([input_typ], result_typ))

 type 'e scope_name_or_var = ScopeName of ScopeName.t | ScopeVar of 'e Var.t

--- a/compiler/shared_ast/type.mli
+++ b/compiler/shared_ast/type.mli
@ -19,8 +19,9 @@ type t = Definitions.typ
 val equal : t -> t -> bool
 val equal_list : t list -> t list -> bool
 val compare : t -> t -> int
-
 val unifiable : t -> t -> bool
+
+val unifiable_list : t list -> t list -> bool
 (** Similar to [equal], but allows TAny holes *)

 val arrow_return : t -> t