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

Version that uses object types instead of polymorphic variants

Browse Source 
in order to get the row polymorphism controlling the GADT that encodes our AST
This commit is contained in:
Louis Gesbert 2023-04-04 11:10:59 +02:00
parent bd870b0c28
commit 55d343d81c
9 changed files with 221 additions and 197 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
compiler/scalc/ast.ml
View File

@ -25,7 +25,9 @@ let dead_value = VarName.fresh ("dead_value", Pos.no_pos)
let handle_default = FuncName.fresh ("handle_default", Pos.no_pos)
let handle_default_opt = FuncName.fresh ("handle_default_opt", Pos.no_pos)
type operator = [ `Monomorphic | `Polymorphic | `Resolved ] Shared_ast.operator
type operator =
< overloaded : no ; monomorphic : yes ; polymorphic : yes ; resolved : yes >
Shared_ast.operator
type expr = naked_expr Marked.pos

322
compiler/shared_ast/definitions.ml
View File

@ -56,55 +56,67 @@ module StateName = Uid.Gen ()
(** These types allow to select the features present in any given expression
type *)
type op_kind = [ `Monomorphic | `Polymorphic | `Overloaded | `Resolved ]
type all_ast_features =
[ `SyntacticNames
| `ResolvedNames
| `ScopeVarStates
| `ScopeVarSimpl
| `ExplicitScopes
| `Assertions
| `DefaultTerms
| `Exceptions ]
type all = [ all_ast_features | op_kind ]
type yes = private Yes
type no = |
type desugared =
[ `Monomorphic
| `Polymorphic
| `Overloaded
| `SyntacticNames
| `ExplicitScopes
| `ScopeVarStates
| `DefaultTerms ]
< monomorphic : yes
; polymorphic : yes
; overloaded : yes
; resolved : no
; syntacticNames : yes
; resolvedNames : no
; scopeVarStates : yes
; scopeVarSimpl : no
; explicitScopes : yes
; assertions : no
; defaultTerms : yes
; exceptions : no >
type scopelang =
[ `Monomorphic
| `Polymorphic
| `Resolved
| `ResolvedNames
| `ExplicitScopes
| `ScopeVarSimpl
| `DefaultTerms ]
< monomorphic : yes
; polymorphic : yes
; overloaded : no
; resolved : yes
; syntacticNames : no
; resolvedNames : yes
; scopeVarStates : no
; scopeVarSimpl : yes
; explicitScopes : yes
; assertions : no
; defaultTerms : yes
; exceptions : no >
type dcalc =
[ `Monomorphic
| `Polymorphic
| `Resolved
| `ResolvedNames
| `Assertions
| `DefaultTerms ]
< monomorphic : yes
; polymorphic : yes
; overloaded : no
; resolved : yes
; syntacticNames : no
; resolvedNames : yes
; scopeVarStates : no
; scopeVarSimpl : no
; explicitScopes : no
; assertions : yes
; defaultTerms : yes
; exceptions : no >
type lcalc =
[ `Monomorphic
| `Polymorphic
| `Resolved
| `ResolvedNames
| `Assertions
| `Exceptions ]
< monomorphic : yes
; polymorphic : yes
; overloaded : no
; resolved : yes
; syntacticNames : no
; resolvedNames : yes
; scopeVarStates : no
; scopeVarSimpl : no
; explicitScopes : no
; assertions : yes
; defaultTerms : no
; exceptions : yes >
type 'a any = < .. > as 'a
type 'a any = [< all ] as 'a
(** ['a any] is 'a, but adds the constraint that it should be restricted to
valid AST kinds *)
@ -141,121 +153,119 @@ type log_entry =
module Op = struct
(** Classification of operators on how they should be typed *)
type 'a any = [> op_kind ] as 'a
type monomorphic = [ `Monomorphic ]
type monomorphic = < monomorphic : yes >
(** Operands and return types of the operator are fixed *)
type polymorphic = [ `Polymorphic ]
type polymorphic = < polymorphic : yes >
(** The operator is truly polymorphic: it's the same runtime function that may
work on multiple types. We require that resolving the argument types from
right to left trivially resolves all type variables declared in the
operator type. *)
type overloaded = [ `Overloaded ]
type overloaded = < overloaded : yes >
(** The operator is ambiguous and requires the types of its arguments to be
known before it can be typed, using a pre-defined table *)
type resolved = [ `Resolved ]
type resolved = < resolved : yes >
(** Explicit monomorphic versions of the overloaded operators *)
type _ t =
(* unary *)
(* * monomorphic *)
| Not : [> `Monomorphic ] t
| GetDay : [> `Monomorphic ] t
| GetMonth : [> `Monomorphic ] t
| GetYear : [> `Monomorphic ] t
| FirstDayOfMonth : [> `Monomorphic ] t
| LastDayOfMonth : [> `Monomorphic ] t
| Not : < monomorphic ; .. > t
| GetDay : < monomorphic ; .. > t
| GetMonth : < monomorphic ; .. > t
| GetYear : < monomorphic ; .. > t
| FirstDayOfMonth : < monomorphic ; .. > t
| LastDayOfMonth : < monomorphic ; .. > t
(* * polymorphic *)
| Length : [> `Polymorphic ] t
| Log : log_entry * Uid.MarkedString.info list -> [> `Polymorphic ] t
| Length : < polymorphic ; .. > t
| Log : log_entry * Uid.MarkedString.info list -> < polymorphic ; .. > t
(* * overloaded *)
| Minus : [> `Overloaded ] t
| Minus_int : [> `Resolved ] t
| Minus_rat : [> `Resolved ] t
| Minus_mon : [> `Resolved ] t
| Minus_dur : [> `Resolved ] t
| ToRat : [> `Overloaded ] t
| ToRat_int : [> `Resolved ] t
| ToRat_mon : [> `Resolved ] t
| ToMoney : [> `Overloaded ] t
| ToMoney_rat : [> `Resolved ] t
| Round : [> `Overloaded ] t
| Round_rat : [> `Resolved ] t
| Round_mon : [> `Resolved ] t
| Minus : < overloaded ; .. > t
| Minus_int : < resolved ; .. > t
| Minus_rat : < resolved ; .. > t
| Minus_mon : < resolved ; .. > t
| Minus_dur : < resolved ; .. > t
| ToRat : < overloaded ; .. > t
| ToRat_int : < resolved ; .. > t
| ToRat_mon : < resolved ; .. > t
| ToMoney : < overloaded ; .. > t
| ToMoney_rat : < resolved ; .. > t
| Round : < overloaded ; .. > t
| Round_rat : < resolved ; .. > t
| Round_mon : < resolved ; .. > t
(* binary *)
(* * monomorphic *)
| And : [> `Monomorphic ] t
| Or : [> `Monomorphic ] t
| Xor : [> `Monomorphic ] t
| And : < monomorphic ; .. > t
| Or : < monomorphic ; .. > t
| Xor : < monomorphic ; .. > t
(* * polymorphic *)
| Eq : [> `Polymorphic ] t
| Map : [> `Polymorphic ] t
| Concat : [> `Polymorphic ] t
| Filter : [> `Polymorphic ] t
| Reduce : [> `Polymorphic ] t
| Eq : < polymorphic ; .. > t
| Map : < polymorphic ; .. > t
| Concat : < polymorphic ; .. > t
| Filter : < polymorphic ; .. > t
| Reduce : < polymorphic ; .. > t
(* * overloaded *)
| Add : [> `Overloaded ] t
| Add_int_int : [> `Resolved ] t
| Add_rat_rat : [> `Resolved ] t
| Add_mon_mon : [> `Resolved ] t
| Add_dat_dur : date_rounding -> [> `Resolved ] t
| Add_dur_dur : [> `Resolved ] t
| Sub : [> `Overloaded ] t
| Sub_int_int : [> `Resolved ] t
| Sub_rat_rat : [> `Resolved ] t
| Sub_mon_mon : [> `Resolved ] t
| Sub_dat_dat : [> `Resolved ] t
| Sub_dat_dur : [> `Resolved ] t
| Sub_dur_dur : [> `Resolved ] t
| Mult : [> `Overloaded ] t
| Mult_int_int : [> `Resolved ] t
| Mult_rat_rat : [> `Resolved ] t
| Mult_mon_rat : [> `Resolved ] t
| Mult_dur_int : [> `Resolved ] t
| Div : [> `Overloaded ] t
| Div_int_int : [> `Resolved ] t
| Div_rat_rat : [> `Resolved ] t
| Div_mon_rat : [> `Resolved ] t
| Div_mon_mon : [> `Resolved ] t
| Div_dur_dur : [> `Resolved ] t
| Lt : [> `Overloaded ] t
| Lt_int_int : [> `Resolved ] t
| Lt_rat_rat : [> `Resolved ] t
| Lt_mon_mon : [> `Resolved ] t
| Lt_dat_dat : [> `Resolved ] t
| Lt_dur_dur : [> `Resolved ] t
| Lte : [> `Overloaded ] t
| Lte_int_int : [> `Resolved ] t
| Lte_rat_rat : [> `Resolved ] t
| Lte_mon_mon : [> `Resolved ] t
| Lte_dat_dat : [> `Resolved ] t
| Lte_dur_dur : [> `Resolved ] t
| Gt : [> `Overloaded ] t
| Gt_int_int : [> `Resolved ] t
| Gt_rat_rat : [> `Resolved ] t
| Gt_mon_mon : [> `Resolved ] t
| Gt_dat_dat : [> `Resolved ] t
| Gt_dur_dur : [> `Resolved ] t
| Gte : [> `Overloaded ] t
| Gte_int_int : [> `Resolved ] t
| Gte_rat_rat : [> `Resolved ] t
| Gte_mon_mon : [> `Resolved ] t
| Gte_dat_dat : [> `Resolved ] t
| Gte_dur_dur : [> `Resolved ] t
| Add : < overloaded ; .. > t
| Add_int_int : < resolved ; .. > t
| Add_rat_rat : < resolved ; .. > t
| Add_mon_mon : < resolved ; .. > t
| Add_dat_dur : date_rounding -> < resolved ; .. > t
| Add_dur_dur : < resolved ; .. > t
| Sub : < overloaded ; .. > t
| Sub_int_int : < resolved ; .. > t
| Sub_rat_rat : < resolved ; .. > t
| Sub_mon_mon : < resolved ; .. > t
| Sub_dat_dat : < resolved ; .. > t
| Sub_dat_dur : < resolved ; .. > t
| Sub_dur_dur : < resolved ; .. > t
| Mult : < overloaded ; .. > t
| Mult_int_int : < resolved ; .. > t
| Mult_rat_rat : < resolved ; .. > t
| Mult_mon_rat : < resolved ; .. > t
| Mult_dur_int : < resolved ; .. > t
| Div : < overloaded ; .. > t
| Div_int_int : < resolved ; .. > t
| Div_rat_rat : < resolved ; .. > t
| Div_mon_rat : < resolved ; .. > t
| Div_mon_mon : < resolved ; .. > t
| Div_dur_dur : < resolved ; .. > t
| Lt : < overloaded ; .. > t
| Lt_int_int : < resolved ; .. > t
| Lt_rat_rat : < resolved ; .. > t
| Lt_mon_mon : < resolved ; .. > t
| Lt_dat_dat : < resolved ; .. > t
| Lt_dur_dur : < resolved ; .. > t
| Lte : < overloaded ; .. > t
| Lte_int_int : < resolved ; .. > t
| Lte_rat_rat : < resolved ; .. > t
| Lte_mon_mon : < resolved ; .. > t
| Lte_dat_dat : < resolved ; .. > t
| Lte_dur_dur : < resolved ; .. > t
| Gt : < overloaded ; .. > t
| Gt_int_int : < resolved ; .. > t
| Gt_rat_rat : < resolved ; .. > t
| Gt_mon_mon : < resolved ; .. > t
| Gt_dat_dat : < resolved ; .. > t
| Gt_dur_dur : < resolved ; .. > t
| Gte : < overloaded ; .. > t
| Gte_int_int : < resolved ; .. > t
| Gte_rat_rat : < resolved ; .. > t
| Gte_mon_mon : < resolved ; .. > t
| Gte_dat_dat : < resolved ; .. > t
| Gte_dur_dur : < resolved ; .. > t
(* Todo: Eq is not an overload at the moment, but it should be one. The
trick is that it needs generation of specific code for arrays, every
struct and enum: operators [Eq_structs of StructName.t], etc. *)
| Eq_int_int : [> `Resolved ] t
| Eq_rat_rat : [> `Resolved ] t
| Eq_mon_mon : [> `Resolved ] t
| Eq_dur_dur : [> `Resolved ] t
| Eq_dat_dat : [> `Resolved ] t
| Eq_int_int : < resolved ; .. > t
| Eq_rat_rat : < resolved ; .. > t
| Eq_mon_mon : < resolved ; .. > t
| Eq_dur_dur : < resolved ; .. > t
| Eq_dat_dat : < resolved ; .. > t
(* ternary *)
(* * polymorphic *)
| Fold : [> `Polymorphic ] t
| Fold : < polymorphic ; .. > t
end
type 'a operator = 'a Op.t
@ -280,12 +290,16 @@ type lit =
type 'a glocation =
| DesugaredScopeVar :
ScopeVar.t Marked.pos * StateName.t option
-> [> `ScopeVarStates ] glocation
| ScopelangScopeVar : ScopeVar.t Marked.pos -> [> `ScopeVarSimpl ] glocation
-> < scopeVarStates : yes ; .. > glocation
| ScopelangScopeVar :
ScopeVar.t Marked.pos
-> < scopeVarSimpl : yes ; .. > glocation
| SubScopeVar :
ScopeName.t * SubScopeName.t Marked.pos * ScopeVar.t Marked.pos
-> [> `ExplicitScopes ] glocation
| ToplevelVar : TopdefName.t Marked.pos -> [> `ExplicitScopes ] glocation
-> < explicitScopes : yes ; .. > glocation
| ToplevelVar :
TopdefName.t Marked.pos
-> < explicitScopes : yes ; .. > glocation
type ('a, 't) gexpr = (('a, 't) naked_gexpr, 't) Marked.t
@ -312,96 +326,96 @@ and ('a, 't) naked_gexpr = ('a, 'a, 't) base_gexpr
and ('a, 'b, 't) base_gexpr =
(* Constructors common to all ASTs *)
| ELit : lit -> ('a, [< all ], 't) base_gexpr
| ELit : lit -> ('a, < .. >, 't) base_gexpr
| EApp : {
f : ('a, 't) gexpr;
args : ('a, 't) gexpr list;
}
-> ('a, [< all ], 't) base_gexpr
-> ('a, < .. >, 't) base_gexpr
| EOp : {
op : 'b operator;
tys : typ list;
}
-> ('a, ([< all ] as 'b), 't) base_gexpr
| EArray : ('a, 't) gexpr list -> ('a, [< all ], 't) base_gexpr
-> ('a, (< .. > as 'b), 't) base_gexpr
| EArray : ('a, 't) gexpr list -> ('a, < .. >, 't) base_gexpr
| EVar : ('a, 't) naked_gexpr Bindlib.var -> ('a, _, 't) base_gexpr
| EAbs : {
binder : (('a, 'a, 't) base_gexpr, ('a, 't) gexpr) Bindlib.mbinder;
tys : typ list;
}
-> ('a, [< all ], 't) base_gexpr
-> ('a, < .. >, 't) base_gexpr
| EIfThenElse : {
cond : ('a, 't) gexpr;
etrue : ('a, 't) gexpr;
efalse : ('a, 't) gexpr;
}
-> ('a, [< all ], 't) base_gexpr
-> ('a, < .. >, 't) base_gexpr
| EStruct : {
name : StructName.t;
fields : ('a, 't) gexpr StructField.Map.t;
}
-> ('a, [< all ], 't) base_gexpr
-> ('a, < .. >, 't) base_gexpr
| EInj : {
name : EnumName.t;
e : ('a, 't) gexpr;
cons : EnumConstructor.t;
}
-> ('a, [< all ], 't) base_gexpr
-> ('a, < .. >, 't) base_gexpr
| EMatch : {
name : EnumName.t;
e : ('a, 't) gexpr;
cases : ('a, 't) gexpr EnumConstructor.Map.t;
}
-> ('a, [< all ], 't) base_gexpr
| ETuple : ('a, 't) gexpr list -> ('a, [< all ], 't) base_gexpr
-> ('a, < .. >, 't) base_gexpr
| ETuple : ('a, 't) gexpr list -> ('a, < .. >, 't) base_gexpr
| ETupleAccess : {
e : ('a, 't) gexpr;
index : int;
size : int;
}
-> ('a, [< all ], 't) base_gexpr
-> ('a, < .. >, 't) base_gexpr
(* Early stages *)
| ELocation : 'b glocation -> ('a, ([< all ] as 'b), 't) base_gexpr
| ELocation : 'b glocation -> ('a, (< .. > as 'b), 't) base_gexpr
| EScopeCall : {
scope : ScopeName.t;
args : ('a, 't) gexpr ScopeVar.Map.t;
}
-> ('a, [< all > `ExplicitScopes ], 't) base_gexpr
-> ('a, < explicitScopes : yes ; .. >, 't) base_gexpr
| EDStructAccess : {
name_opt : StructName.t option;
e : ('a, 't) gexpr;
field : IdentName.t;
}
-> ('a, [< all > `SyntacticNames ], 't) base_gexpr
-> ('a, < syntacticNames : yes ; .. >, 't) base_gexpr
(** [desugared] has ambiguous struct fields *)
| EStructAccess : {
name : StructName.t;
e : ('a, 't) gexpr;
field : StructField.t;
}
-> ('a, [< all > `ResolvedNames ], 't) base_gexpr
-> ('a, < resolvedNames : yes ; .. >, 't) base_gexpr
(** Resolved struct/enums, after [desugared] *)
(* Lambda-like *)
| EAssert : ('a, 't) gexpr -> ('a, [< all > `Assertions ], 't) base_gexpr
| EAssert : ('a, 't) gexpr -> ('a, < assertions : yes ; .. >, 't) base_gexpr
(* Default terms *)
| EDefault : {
excepts : ('a, 't) gexpr list;
just : ('a, 't) gexpr;
cons : ('a, 't) gexpr;
}
-> ('a, [< all > `DefaultTerms ], 't) base_gexpr
| EEmptyError : ('a, [< all > `DefaultTerms ], 't) base_gexpr
-> ('a, < defaultTerms : yes ; .. >, 't) base_gexpr
| EEmptyError : ('a, < defaultTerms : yes ; .. >, 't) base_gexpr
| EErrorOnEmpty :
('a, 't) gexpr
-> ('a, [< all > `DefaultTerms ], 't) base_gexpr
-> ('a, < defaultTerms : yes ; .. >, 't) base_gexpr
(* Lambda calculus with exceptions *)
| ERaise : except -> ('a, [< all > `Exceptions ], 't) base_gexpr
| ERaise : except -> ('a, < exceptions : yes ; .. >, 't) base_gexpr
| ECatch : {
body : ('a, 't) gexpr;
exn : except;
handler : ('a, 't) gexpr;
}
-> ('a, [< all > `Exceptions ], 't) base_gexpr
-> ('a, < exceptions : yes ; .. >, 't) base_gexpr
type ('a, 't) boxed_gexpr = (('a, 't) naked_gexpr Bindlib.box, 't) Marked.t
(** The annotation is lifted outside of the box for expressions *)

3
compiler/shared_ast/expr.ml
View File

@ -252,8 +252,7 @@ let rec map_top_down ~f e = map ~f:(map_top_down ~f) (f e)
let map_marks ~f e =
map_top_down ~f:(fun e -> Marked.(mark (f (get_mark e)) (unmark e))) e
(* Folds the given function on the direct children of the given expression. Does
not open binders. *)
(* Folds the given function on the direct children of the given expression. *)
let shallow_fold
(type a)
(f : (a, 'm) gexpr -> 'acc -> 'acc)

30
compiler/shared_ast/expr.mli
View File

@ -64,16 +64,18 @@ val eapp :
('a any, 't) boxed_gexpr
val eassert :
('a, 't) boxed_gexpr -> 't -> (([< all > `Assertions ] as 'a), 't) boxed_gexpr
('a, 't) boxed_gexpr ->
't ->
((< assertions : yes ; .. > as 'a), 't) boxed_gexpr
val eop : 'a operator -> typ list -> 't -> (([< all ] as 'a), 't) boxed_gexpr
val eop : 'a operator -> typ list -> 't -> ('a any, 't) boxed_gexpr
val edefault :
('a, 't) boxed_gexpr list ->
('a, 't) boxed_gexpr ->
('a, 't) boxed_gexpr ->
't ->
(([< all > `DefaultTerms ] as 'a), 't) boxed_gexpr
((< defaultTerms : yes ; .. > as 'a), 't) boxed_gexpr
val eifthenelse :
('a, 't) boxed_gexpr ->
@ -82,22 +84,22 @@ val eifthenelse :
't ->
('a any, 't) boxed_gexpr
val eemptyerror : 't -> (([< all > `DefaultTerms ] as 'a), 't) boxed_gexpr
val eemptyerror : 't -> ((< defaultTerms : yes ; .. > as 'a), 't) boxed_gexpr
val eerroronempty :
('a, 't) boxed_gexpr ->
't ->
(([< all > `DefaultTerms ] as 'a), 't) boxed_gexpr
((< defaultTerms : yes ; .. > as 'a), 't) boxed_gexpr
val ecatch :
('a, 't) boxed_gexpr ->
except ->
('a, 't) boxed_gexpr ->
't ->
(([< all > `Exceptions ] as 'a), 't) boxed_gexpr
((< exceptions : yes ; .. > as 'a), 't) boxed_gexpr
val eraise : except -> 't -> ([< all > `Exceptions ], 't) boxed_gexpr
val elocation : 'a glocation -> 't -> (([< all ] as 'a), 't) boxed_gexpr
val eraise : except -> 't -> (< exceptions : yes ; .. >, 't) boxed_gexpr
val elocation : 'a glocation -> 't -> ((< .. > as 'a), 't) boxed_gexpr
val estruct :
StructName.t ->
@ -110,14 +112,14 @@ val edstructaccess :
IdentName.t ->
StructName.t option ->
't ->
(([< all > `SyntacticNames ] as 'a), 't) boxed_gexpr
((< syntacticNames : yes ; .. > as 'a), 't) boxed_gexpr
val estructaccess :
('a, 't) boxed_gexpr ->
StructField.t ->
StructName.t ->
't ->
(([< all > `ResolvedNames ] as 'a), 't) boxed_gexpr
((< resolvedNames : yes ; .. > as 'a), 't) boxed_gexpr
val einj :
('a, 't) boxed_gexpr ->
@ -137,7 +139,7 @@ val escopecall :
ScopeName.t ->
('a, 't) boxed_gexpr ScopeVar.Map.t ->
't ->
(([< all > `ExplicitScopes ] as 'a), 't) boxed_gexpr
((< explicitScopes : yes ; .. > as 'a), 't) boxed_gexpr
(** Manipulation of marks *)
@ -280,7 +282,7 @@ val make_app :
('a any, 'm mark) boxed_gexpr
val empty_thunked_term :
'm mark -> ([< all > `DefaultTerms ], 'm mark) boxed_gexpr
'm mark -> (< defaultTerms : yes ; .. >, 'm mark) boxed_gexpr
val make_let_in :
('a, 'm mark) gexpr Var.t ->
@ -303,7 +305,7 @@ val make_default :
('a, 't) boxed_gexpr ->
('a, 't) boxed_gexpr ->
't ->
(([< all > `Polymorphic `DefaultTerms ] as 'a), 't) boxed_gexpr
((< polymorphic : yes ; defaultTerms : yes ; .. > as 'a), 't) boxed_gexpr
(** [make_default ?pos exceptions just cons] builds a term semantically
equivalent to [<exceptions | just :- cons>] (the [EDefault] constructor)
while avoiding redundant nested constructions. The position is extracted
@ -328,7 +330,7 @@ val skip_wrappers : ('a, 'm) gexpr -> ('a, 'm) gexpr
(** Removes surface logging calls and [EErrorOnEmpty] nodes. Shallow function *)
val remove_logging_calls :
(([< all > `Polymorphic ] as 'a), 't) gexpr -> ('a, 't) boxed_gexpr
((< polymorphic : yes ; .. > as 'a), 't) gexpr -> ('a, 't) boxed_gexpr
(** Removes all calls to [Log] unary operators in the AST, replacing them by
their argument. *)

2
compiler/shared_ast/interpreter.ml
View File

@ -137,7 +137,7 @@ let handle_eq evaluate_operator ctx pos e1 e2 =
let rec evaluate_operator
evaluate_expr
ctx
(op : [< dcalc | lcalc ] operator)
(op : < overloaded : no ; .. > operator)
m
args =
let pos = Expr.mark_pos m in

2
compiler/shared_ast/interpreter.mli
View File

@ -33,7 +33,7 @@ val evaluate_operator :
operator. *)
val evaluate_expr :
decl_ctx -> (([< dcalc | lcalc ] as 'a), 'm mark) gexpr -> ('a, 'm mark) gexpr
decl_ctx -> ((< .. > as 'a), 'm mark) gexpr -> ('a, 'm mark) gexpr
(** Evaluates an expression according to the semantics of the default calculus. *)
val interpret_program_dcalc :

31
compiler/shared_ast/operator.ml
View File

@ -302,10 +302,10 @@ let equal t1 t2 = compare t1 t2 = 0
let kind_dispatch :
type a.
polymorphic:([> polymorphic ] t -> 'b) ->
monomorphic:([> monomorphic ] t -> 'b) ->
?overloaded:([> overloaded ] t -> 'b) ->
?resolved:([> resolved ] t -> 'b) ->
polymorphic:(< polymorphic : yes ; .. > t -> 'b) ->
monomorphic:(< monomorphic : yes ; .. > t -> 'b) ->
?overloaded:(< overloaded : yes ; .. > t -> 'b) ->
?resolved:(< resolved : yes ; .. > t -> 'b) ->
a t ->
'b =
fun ~polymorphic ~monomorphic ?(overloaded = fun _ -> assert false)
@ -333,16 +333,19 @@ let kind_dispatch :
resolved op
type 'a no_overloads =
[< all_ast_features | `Monomorphic | `Polymorphic | `Resolved ] as 'a
< overloaded : no
; monomorphic : yes
; polymorphic : yes
; resolved : yes
; .. >
as
'a
let translate (t : [> `Monomorphic | `Polymorphic | `Resolved ] no_overloads t)
=
let translate (t : 'a no_overloads t) : 'b no_overloads t =
match t with
| ( Not | GetDay | GetMonth | GetYear | FirstDayOfMonth | LastDayOfMonth | And
| Or | Xor ) as op ->
op
| (Log _ | Length | Eq | Map | Concat | Filter | Reduce | Fold) as op -> op
| ( Minus_int | Minus_rat | Minus_mon | Minus_dur | ToRat_int | ToRat_mon
| Or | Xor | Log _ | Length | Eq | Map | 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
@ -443,8 +446,8 @@ let resolved_type ((op : resolved t), pos) =
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 ] t * [ `Straight | `Reversed ] =
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
@ -504,7 +507,7 @@ let resolve_overload_aux (op : [< overloaded ] t) (operands : typ_lit list) :
raise Not_found
let resolve_overload ctx (op : overloaded t Marked.pos) (operands : typ list) :
[> resolved ] t * [ `Straight | `Reversed ] =
< resolved : yes ; .. > t * [ `Straight | `Reversed ] =
try
let operands =
List.map

22
compiler/shared_ast/operator.mli
View File

@ -42,20 +42,24 @@ val name : 'a t -> string
symbols, e.g. [+$]. *)
val kind_dispatch :
polymorphic:([> polymorphic ] t -> 'b) ->
monomorphic:([> monomorphic ] t -> 'b) ->
?overloaded:([> overloaded ] t -> 'b) ->
?resolved:([> resolved ] t -> 'b) ->
polymorphic:(< polymorphic : yes ; .. > t -> 'b) ->
monomorphic:(< monomorphic : yes ; .. > t -> 'b) ->
?overloaded:(< overloaded : yes ; .. > t -> 'b) ->
?resolved:(< resolved : yes ; .. > t -> 'b) ->
'a t ->
'b
(** Calls one of the supplied functions depending on the kind of the operator *)
type 'a no_overloads =
[< all_ast_features | `Monomorphic | `Polymorphic | `Resolved ] as 'a
< overloaded : no
; monomorphic : yes
; polymorphic : yes
; resolved : yes
; .. >
as
'a
val translate :
[> `Monomorphic | `Polymorphic | `Resolved ] no_overloads t ->
[> `Monomorphic | `Polymorphic | `Resolved ] t
val translate : 'a no_overloads t -> 'b no_overloads t
(** An identity function that allows translating an operator between different
passes that don't change operator types *)
@ -79,7 +83,7 @@ val resolve_overload :
decl_ctx ->
overloaded t Marked.pos ->
typ list ->
[> resolved ] t * [ `Straight | `Reversed ]
< resolved : yes ; .. > t * [ `Straight | `Reversed ]
(** Some overloads are sugar for an operation with reversed operands, e.g.
[TRat * TMoney] is using [mult_mon_rat]. [`Reversed] is returned to signify
this case. *)

2
compiler/shared_ast/print.ml
View File

@ -242,7 +242,7 @@ let operator_to_string : type a. a Op.t -> string =
| Eq_dat_dat -> "=@"
| Fold -> "fold"
let operator : type a. Format.formatter -> a Op.t -> unit =
let operator : type a. Format.formatter -> a operator -> unit =
fun fmt op ->
let open Op in
match op with