mirror of
https://github.com/CatalaLang/catala.git
synced 2024-11-08 07:51:43 +03:00
Improve integration of marks into the main AST
Two interdependent changes here:
1. Enforce all instances of Shared_ast.gexpr to use the generic type for marks.
This makes the interfaces a tad simpler to manipulate: you now write
`('a, 'm) gexpr` rather than `('a, 'm mark) gexpr`.
2. Define a polymorphic `Custom` mark case for use by pass-specific annotations.
And leverage this in the typing module
This commit is contained in:
Louis Gesbert
parent
fc531777c0
commit
209be6b758
@ -17,7 +17,7 @@
|
||||
|
||||
open Shared_ast
|
||||
|
||||
type 'm naked_expr = (dcalc, 'm mark) naked_gexpr
|
||||
and 'm expr = (dcalc, 'm mark) gexpr
|
||||
type 'm naked_expr = (dcalc, 'm) naked_gexpr
|
||||
and 'm expr = (dcalc, 'm) gexpr
|
||||
|
||||
type 'm program = 'm expr Shared_ast.program
|
||||
|
||||
@ -19,7 +19,7 @@
|
||||
|
||||
open Shared_ast
|
||||
|
||||
type 'm naked_expr = (dcalc, 'm mark) naked_gexpr
|
||||
and 'm expr = (dcalc, 'm mark) gexpr
|
||||
type 'm naked_expr = (dcalc, 'm) naked_gexpr
|
||||
and 'm expr = (dcalc, 'm) gexpr
|
||||
|
||||
type 'm program = 'm expr Shared_ast.program
|
||||
|
||||
@ -65,7 +65,7 @@ let mark_tany m pos = Expr.with_ty m (Mark.add pos TAny) ~pos
|
||||
|
||||
(* Expression argument is used as a type witness, its type and positions aren't
|
||||
used *)
|
||||
let pos_mark_mk (type a m) (e : (a, m mark) gexpr) :
|
||||
let pos_mark_mk (type a m) (e : (a, m) gexpr) :
|
||||
(Pos.t -> m mark) * ((_, Pos.t) Mark.ed -> m mark) =
|
||||
let pos_mark pos =
|
||||
Expr.map_mark (fun _ -> pos) (fun _ -> TAny, pos) (Mark.get e)
|
||||
@ -75,8 +75,8 @@ let pos_mark_mk (type a m) (e : (a, m mark) gexpr) :
|
||||
|
||||
let merge_defaults
|
||||
~(is_func : bool)
|
||||
(caller : (dcalc, 'm mark) boxed_gexpr)
|
||||
(callee : (dcalc, 'm mark) boxed_gexpr) : (dcalc, 'm mark) boxed_gexpr =
|
||||
(caller : (dcalc, 'm) boxed_gexpr)
|
||||
(callee : (dcalc, 'm) boxed_gexpr) : (dcalc, 'm) boxed_gexpr =
|
||||
(* the merging of the two defaults, from the reentrant caller and the callee,
|
||||
is straightfoward in the general case and a little subtler when the
|
||||
variable being defined is a function. *)
|
||||
@ -92,7 +92,7 @@ let merge_defaults
|
||||
let pos = Expr.mark_pos m in
|
||||
Expr.make_app caller
|
||||
(List.map2
|
||||
(fun (var : (dcalc, 'm mark) naked_gexpr Bindlib.var) ty ->
|
||||
(fun (var : (dcalc, 'm) naked_gexpr Bindlib.var) ty ->
|
||||
Expr.evar var
|
||||
(* we have to correctly propagate types when doing this
|
||||
rewriting *)
|
||||
|
||||
@ -83,7 +83,7 @@ module LocationSet : Set.S with type elt = location Mark.pos = Set.Make (struct
|
||||
let compare = Expr.compare_location
|
||||
end)
|
||||
|
||||
type expr = (desugared, untyped mark) gexpr
|
||||
type expr = (desugared, untyped) gexpr
|
||||
|
||||
module ExprMap = Map.Make (struct
|
||||
type t = expr
|
||||
|
||||
@ -41,7 +41,7 @@ module AssertionName : Uid.Id with type info = Uid.MarkedString.info
|
||||
|
||||
(** {2 Expressions} *)
|
||||
|
||||
type expr = (desugared, untyped mark) gexpr
|
||||
type expr = (desugared, untyped) gexpr
|
||||
(** See {!type:Shared_ast.naked_gexpr} for the complete definition *)
|
||||
|
||||
type location = desugared glocation
|
||||
|
||||
@ -16,8 +16,8 @@
|
||||
|
||||
open Shared_ast
|
||||
|
||||
type 'm naked_expr = (lcalc, 'm mark) naked_gexpr
|
||||
and 'm expr = (lcalc, 'm mark) gexpr
|
||||
type 'm naked_expr = (lcalc, 'm) naked_gexpr
|
||||
and 'm expr = (lcalc, 'm) gexpr
|
||||
|
||||
type 'm program = 'm expr Shared_ast.program
|
||||
|
||||
|
||||
@ -20,8 +20,8 @@ open Shared_ast
|
||||
|
||||
(** {1 Abstract syntax tree} *)
|
||||
|
||||
type 'm naked_expr = (lcalc, 'm mark) naked_gexpr
|
||||
and 'm expr = (lcalc, 'm mark) gexpr
|
||||
type 'm naked_expr = (lcalc, 'm) naked_gexpr
|
||||
and 'm expr = (lcalc, 'm) gexpr
|
||||
|
||||
type 'm program = 'm expr Shared_ast.program
|
||||
|
||||
@ -30,78 +30,76 @@ type 'm program = 'm expr Shared_ast.program
|
||||
(** {2 Term building and management for the [option] monad}*)
|
||||
|
||||
module OptionMonad : sig
|
||||
val return :
|
||||
mark:'m mark -> ('a any, 'm mark) boxed_gexpr -> ('a, 'm mark) boxed_gexpr
|
||||
|
||||
val empty : mark:'m mark -> ('a any, 'm mark) boxed_gexpr
|
||||
val return : mark:'m mark -> ('a any, 'm) boxed_gexpr -> ('a, 'm) boxed_gexpr
|
||||
val empty : mark:'m mark -> ('a any, 'm) boxed_gexpr
|
||||
|
||||
val bind_var :
|
||||
mark:'m mark ->
|
||||
('a any, 'm mark) boxed_gexpr ->
|
||||
('a, 'm mark) gexpr Var.t ->
|
||||
('a, 'm mark) boxed_gexpr ->
|
||||
('a, 'm mark) boxed_gexpr
|
||||
('a any, 'm) boxed_gexpr ->
|
||||
('a, 'm) gexpr Var.t ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr
|
||||
|
||||
val bind :
|
||||
mark:'m mark ->
|
||||
var_name:string ->
|
||||
('a any, 'm mark) boxed_gexpr ->
|
||||
('a, 'm mark) boxed_gexpr ->
|
||||
('a, 'm mark) boxed_gexpr
|
||||
('a any, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr
|
||||
|
||||
val bind_cont :
|
||||
mark:'m mark ->
|
||||
var_name:string ->
|
||||
(('a any, 'm mark) gexpr Var.t -> ('a, 'm mark) boxed_gexpr) ->
|
||||
('a, 'm mark) boxed_gexpr ->
|
||||
('a, 'm mark) boxed_gexpr
|
||||
(('a any, 'm) gexpr Var.t -> ('a, 'm) boxed_gexpr) ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr
|
||||
|
||||
val mbind_mvar :
|
||||
mark:'m mark ->
|
||||
('a any, 'm mark) boxed_gexpr ->
|
||||
('a, 'm mark) gexpr Var.t list ->
|
||||
('a, 'm mark) boxed_gexpr list ->
|
||||
('a, 'm mark) boxed_gexpr
|
||||
('a any, 'm) boxed_gexpr ->
|
||||
('a, 'm) gexpr Var.t list ->
|
||||
('a, 'm) boxed_gexpr list ->
|
||||
('a, 'm) boxed_gexpr
|
||||
|
||||
val mbind :
|
||||
mark:'m mark ->
|
||||
var_name:string ->
|
||||
('a any, 'm mark) boxed_gexpr ->
|
||||
('a, 'm mark) boxed_gexpr list ->
|
||||
('a, 'm mark) boxed_gexpr
|
||||
('a any, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr list ->
|
||||
('a, 'm) boxed_gexpr
|
||||
|
||||
val mbind_cont :
|
||||
mark:'m mark ->
|
||||
var_name:string ->
|
||||
(('a any, 'm mark) gexpr Var.t list -> ('a, 'm mark) boxed_gexpr) ->
|
||||
('a, 'm mark) boxed_gexpr list ->
|
||||
('a, 'm mark) boxed_gexpr
|
||||
(('a any, 'm) gexpr Var.t list -> ('a, 'm) boxed_gexpr) ->
|
||||
('a, 'm) boxed_gexpr list ->
|
||||
('a, 'm) boxed_gexpr
|
||||
|
||||
val error_on_empty :
|
||||
mark:'m mark ->
|
||||
var_name:string ->
|
||||
?toplevel:bool ->
|
||||
((< exceptions : yes ; .. > as 'a), 'm mark) boxed_gexpr ->
|
||||
('a, 'm mark) boxed_gexpr
|
||||
((< exceptions : yes ; .. > as 'a), 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr
|
||||
|
||||
val map :
|
||||
mark:'m mark ->
|
||||
var_name:string ->
|
||||
((< exceptions : no ; .. > as 'a), 'm mark) boxed_gexpr ->
|
||||
('a, 'm mark) boxed_gexpr ->
|
||||
('a, 'm mark) boxed_gexpr
|
||||
((< exceptions : no ; .. > as 'a), 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr
|
||||
|
||||
val mmap_mvar :
|
||||
mark:'m mark ->
|
||||
('a any, 'm mark) boxed_gexpr ->
|
||||
('a, 'm mark) gexpr Var.t list ->
|
||||
('a, 'm mark) boxed_gexpr list ->
|
||||
('a, 'm mark) boxed_gexpr
|
||||
('a any, 'm) boxed_gexpr ->
|
||||
('a, 'm) gexpr Var.t list ->
|
||||
('a, 'm) boxed_gexpr list ->
|
||||
('a, 'm) boxed_gexpr
|
||||
|
||||
val mmap :
|
||||
mark:'m mark ->
|
||||
var_name:string ->
|
||||
('a any, 'm mark) boxed_gexpr ->
|
||||
('a, 'm mark) boxed_gexpr list ->
|
||||
('a, 'm mark) boxed_gexpr
|
||||
('a any, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr list ->
|
||||
('a, 'm) boxed_gexpr
|
||||
end
|
||||
|
||||
@ -76,8 +76,7 @@ let trans_op : dcalc Op.t -> lcalc Op.t = Operator.translate
|
||||
type 'm var_ctx = { info_pure : bool; is_scope : bool; var : 'm Ast.expr Var.t }
|
||||
|
||||
type 'm ctx = {
|
||||
ctx_vars :
|
||||
((dcalc, 'm mark) Shared_ast__Definitions.gexpr, 'm var_ctx) Var.Map.t;
|
||||
ctx_vars : ((dcalc, 'm) gexpr, 'm var_ctx) Var.Map.t;
|
||||
ctx_context_name : string;
|
||||
}
|
||||
|
||||
@ -97,8 +96,8 @@ let trans_var (ctx : 'm ctx) (x : 'm D.expr Var.t) : 'm Ast.expr Var.t =
|
||||
literals, this mean that a expression of type [money] will be of type
|
||||
[money option]. We rely on later optimization to shorten the size of the
|
||||
generated code. *)
|
||||
let rec trans (ctx : typed ctx) (e : typed D.expr) :
|
||||
(lcalc, typed mark) boxed_gexpr =
|
||||
let rec trans (ctx : typed ctx) (e : typed D.expr) : (lcalc, typed) boxed_gexpr
|
||||
=
|
||||
let m = Mark.get e in
|
||||
let mark = m in
|
||||
let pos = Expr.pos e in
|
||||
@ -622,7 +621,7 @@ let rec trans_scope_let (ctx : typed ctx) (s : typed D.expr scope_let) =
|
||||
scope_let_expr scope_let_next
|
||||
|
||||
and trans_scope_body_expr ctx s :
|
||||
(lcalc, typed mark) gexpr scope_body_expr Bindlib.box =
|
||||
(lcalc, typed) gexpr scope_body_expr Bindlib.box =
|
||||
match s with
|
||||
| Result e -> begin
|
||||
(* invariant : result is always in the form of a record. *)
|
||||
@ -662,7 +661,7 @@ let trans_scope_body
|
||||
binder
|
||||
|
||||
let rec trans_code_items (ctx : typed ctx) (c : typed D.expr code_item_list) :
|
||||
(lcalc, typed mark) gexpr code_item_list Bindlib.box =
|
||||
(lcalc, typed) gexpr code_item_list Bindlib.box =
|
||||
match c with
|
||||
| Nil -> Bindlib.box Nil
|
||||
| Cons (c, next) -> (
|
||||
|
||||
@ -37,8 +37,7 @@ let value_level = { eval_struct = false; eval_op = true; eval_default = true }
|
||||
|
||||
module Env = struct
|
||||
type 'm t =
|
||||
| Env of
|
||||
((dcalc, 'm mark) gexpr, ((dcalc, 'm mark) gexpr * 'm t) ref) Var.Map.t
|
||||
| Env of ((dcalc, 'm) gexpr, ((dcalc, 'm) gexpr * 'm t) ref) Var.Map.t
|
||||
|
||||
let find v (Env t) = Var.Map.find v t
|
||||
let add v e e_env (Env t) = Env (Var.Map.add v (ref (e, e_env)) t)
|
||||
@ -62,8 +61,8 @@ let rec lazy_eval :
|
||||
decl_ctx ->
|
||||
'm Env.t ->
|
||||
laziness_level ->
|
||||
(dcalc, 'm mark) gexpr ->
|
||||
(dcalc, 'm mark) gexpr * 'm Env.t =
|
||||
(dcalc, 'm) gexpr ->
|
||||
(dcalc, 'm) gexpr * 'm Env.t =
|
||||
fun ctx env llevel e0 ->
|
||||
let eval_to_value ?(eval_default = true) env e =
|
||||
lazy_eval ctx env { value_level with eval_default } e
|
||||
@ -212,9 +211,8 @@ let rec lazy_eval :
|
||||
| _ -> error e "Invalid assertion condition %a" Expr.format e)
|
||||
| _ -> .
|
||||
|
||||
let interpret_program
|
||||
(prg : ('dcalc, 'm mark) gexpr program)
|
||||
(scope : ScopeName.t) : ('t, 'm mark) gexpr * 'm Env.t =
|
||||
let interpret_program (prg : ('dcalc, 'm) gexpr program) (scope : ScopeName.t) :
|
||||
('t, 'm) gexpr * 'm Env.t =
|
||||
let ctx = prg.decl_ctx in
|
||||
let all_env, scopes =
|
||||
Scope.fold_left prg.code_items ~init:(Env.empty, ScopeName.Map.empty)
|
||||
|
||||
@ -25,7 +25,7 @@ module LocationSet : Set.S with type elt = location Mark.pos = Set.Make (struct
|
||||
let compare = Expr.compare_location
|
||||
end)
|
||||
|
||||
type 'm expr = (scopelang, 'm mark) gexpr
|
||||
type 'm expr = (scopelang, 'm) gexpr
|
||||
|
||||
let rec locations_used (e : 'm expr) : LocationSet.t =
|
||||
match e with
|
||||
|
||||
@ -27,7 +27,7 @@ module LocationSet : Set.S with type elt = location Mark.pos
|
||||
|
||||
(** {1 Abstract syntax tree} *)
|
||||
|
||||
type 'm expr = (scopelang, 'm mark) gexpr
|
||||
type 'm expr = (scopelang, 'm) gexpr
|
||||
|
||||
val locations_used : 'm expr -> LocationSet.t
|
||||
|
||||
|
||||
@ -287,6 +287,24 @@ end
|
||||
type 'a operator = 'a Op.t
|
||||
type except = ConflictError | EmptyError | NoValueProvided | Crash
|
||||
|
||||
(** {2 Markings} *)
|
||||
|
||||
type untyped = { pos : Pos.t } [@@caml.unboxed]
|
||||
type typed = { pos : Pos.t; ty : typ }
|
||||
type 'a custom = { pos : Pos.t; custom : 'a }
|
||||
|
||||
(** The generic type of AST markings. Using a GADT allows functions to be
|
||||
polymorphic in the marking, but still do transformations on types when
|
||||
appropriate. The [Custom] case can be used within passes that need to store
|
||||
specific information, e.g. typing *)
|
||||
type _ mark =
|
||||
| Untyped : untyped -> untyped mark
|
||||
| Typed : typed -> typed mark
|
||||
| Custom : 'a custom -> 'a custom mark
|
||||
|
||||
type ('a, 'm) marked = ('a, 'm mark) Mark.ed
|
||||
(** Type of values marked with the above standard mark GADT *)
|
||||
|
||||
(** {2 Generic expressions} *)
|
||||
|
||||
(** Define a common base type for the expressions in most passes of the compiler *)
|
||||
@ -317,9 +335,9 @@ type 'a glocation =
|
||||
TopdefName.t Mark.pos
|
||||
-> < explicitScopes : yes ; .. > glocation
|
||||
|
||||
type ('a, 't) gexpr = (('a, 't) naked_gexpr, 't) Mark.ed
|
||||
type ('a, 'm) gexpr = (('a, 'm) naked_gexpr, 'm) marked
|
||||
|
||||
and ('a, 't) naked_gexpr = ('a, 'a, 't) base_gexpr
|
||||
and ('a, 'm) naked_gexpr = ('a, 'a, 'm) base_gexpr
|
||||
(** General expressions: groups all expression cases of the different ASTs, and
|
||||
uses a GADT to eliminate irrelevant cases for each one. The ['t] annotations
|
||||
are also totally unconstrained at this point. The dcalc exprs, for ex ample,
|
||||
@ -340,132 +358,117 @@ and ('a, 't) naked_gexpr = ('a, 'a, 't) base_gexpr
|
||||
well-formed AST types, but differentiating them ephemerally allows us to do
|
||||
well-typed recursive transformations on the AST that change its type *)
|
||||
|
||||
and ('a, 'b, 't) base_gexpr =
|
||||
and ('a, 'b, 'm) base_gexpr =
|
||||
(* Constructors common to all ASTs *)
|
||||
| ELit : lit -> ('a, < .. >, 't) base_gexpr
|
||||
| ELit : lit -> ('a, < .. >, 'm) base_gexpr
|
||||
| EApp : {
|
||||
f : ('a, 't) gexpr;
|
||||
args : ('a, 't) gexpr list;
|
||||
f : ('a, 'm) gexpr;
|
||||
args : ('a, 'm) gexpr list;
|
||||
}
|
||||
-> ('a, < .. >, 't) base_gexpr
|
||||
-> ('a, < .. >, 'm) base_gexpr
|
||||
| EOp : {
|
||||
op : 'b operator;
|
||||
tys : typ list;
|
||||
}
|
||||
-> ('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
|
||||
-> ('a, (< .. > as 'b), 'm) base_gexpr
|
||||
| EArray : ('a, 'm) gexpr list -> ('a, < .. >, 'm) base_gexpr
|
||||
| EVar : ('a, 'm) naked_gexpr Bindlib.var -> ('a, _, 'm) base_gexpr
|
||||
| EAbs : {
|
||||
binder : (('a, 'a, 't) base_gexpr, ('a, 't) gexpr) Bindlib.mbinder;
|
||||
binder : (('a, 'a, 'm) base_gexpr, ('a, 'm) gexpr) Bindlib.mbinder;
|
||||
tys : typ list;
|
||||
}
|
||||
-> ('a, < .. >, 't) base_gexpr
|
||||
-> ('a, < .. >, 'm) base_gexpr
|
||||
| EIfThenElse : {
|
||||
cond : ('a, 't) gexpr;
|
||||
etrue : ('a, 't) gexpr;
|
||||
efalse : ('a, 't) gexpr;
|
||||
cond : ('a, 'm) gexpr;
|
||||
etrue : ('a, 'm) gexpr;
|
||||
efalse : ('a, 'm) gexpr;
|
||||
}
|
||||
-> ('a, < .. >, 't) base_gexpr
|
||||
-> ('a, < .. >, 'm) base_gexpr
|
||||
| EStruct : {
|
||||
name : StructName.t;
|
||||
fields : ('a, 't) gexpr StructField.Map.t;
|
||||
fields : ('a, 'm) gexpr StructField.Map.t;
|
||||
}
|
||||
-> ('a, < .. >, 't) base_gexpr
|
||||
-> ('a, < .. >, 'm) base_gexpr
|
||||
| EInj : {
|
||||
name : EnumName.t;
|
||||
e : ('a, 't) gexpr;
|
||||
e : ('a, 'm) gexpr;
|
||||
cons : EnumConstructor.t;
|
||||
}
|
||||
-> ('a, < .. >, 't) base_gexpr
|
||||
-> ('a, < .. >, 'm) base_gexpr
|
||||
| EMatch : {
|
||||
name : EnumName.t;
|
||||
e : ('a, 't) gexpr;
|
||||
cases : ('a, 't) gexpr EnumConstructor.Map.t;
|
||||
e : ('a, 'm) gexpr;
|
||||
cases : ('a, 'm) gexpr EnumConstructor.Map.t;
|
||||
}
|
||||
-> ('a, < .. >, 't) base_gexpr
|
||||
| ETuple : ('a, 't) gexpr list -> ('a, < .. >, 't) base_gexpr
|
||||
-> ('a, < .. >, 'm) base_gexpr
|
||||
| ETuple : ('a, 'm) gexpr list -> ('a, < .. >, 'm) base_gexpr
|
||||
| ETupleAccess : {
|
||||
e : ('a, 't) gexpr;
|
||||
e : ('a, 'm) gexpr;
|
||||
index : int;
|
||||
size : int;
|
||||
}
|
||||
-> ('a, < .. >, 't) base_gexpr
|
||||
-> ('a, < .. >, 'm) base_gexpr
|
||||
(* Early stages *)
|
||||
| ELocation : 'b glocation -> ('a, (< .. > as 'b), 't) base_gexpr
|
||||
| ELocation : 'b glocation -> ('a, (< .. > as 'b), 'm) base_gexpr
|
||||
| EScopeCall : {
|
||||
scope : ScopeName.t;
|
||||
args : ('a, 't) gexpr ScopeVar.Map.t;
|
||||
args : ('a, 'm) gexpr ScopeVar.Map.t;
|
||||
}
|
||||
-> ('a, < explicitScopes : yes ; .. >, 't) base_gexpr
|
||||
-> ('a, < explicitScopes : yes ; .. >, 'm) base_gexpr
|
||||
| EDStructAccess : {
|
||||
name_opt : StructName.t option;
|
||||
e : ('a, 't) gexpr;
|
||||
e : ('a, 'm) gexpr;
|
||||
field : IdentName.t;
|
||||
}
|
||||
-> ('a, < syntacticNames : yes ; .. >, 't) base_gexpr
|
||||
-> ('a, < syntacticNames : yes ; .. >, 'm) base_gexpr
|
||||
(** [desugared] has ambiguous struct fields *)
|
||||
| EStructAccess : {
|
||||
name : StructName.t;
|
||||
e : ('a, 't) gexpr;
|
||||
e : ('a, 'm) gexpr;
|
||||
field : StructField.t;
|
||||
}
|
||||
-> ('a, < resolvedNames : yes ; .. >, 't) base_gexpr
|
||||
-> ('a, < resolvedNames : yes ; .. >, 'm) base_gexpr
|
||||
(** Resolved struct/enums, after [desugared] *)
|
||||
(* Lambda-like *)
|
||||
| EAssert : ('a, 't) gexpr -> ('a, < assertions : yes ; .. >, 't) base_gexpr
|
||||
| EAssert : ('a, 'm) gexpr -> ('a, < assertions : yes ; .. >, 'm) base_gexpr
|
||||
(* Default terms *)
|
||||
| EDefault : {
|
||||
excepts : ('a, 't) gexpr list;
|
||||
just : ('a, 't) gexpr;
|
||||
cons : ('a, 't) gexpr;
|
||||
excepts : ('a, 'm) gexpr list;
|
||||
just : ('a, 'm) gexpr;
|
||||
cons : ('a, 'm) gexpr;
|
||||
}
|
||||
-> ('a, < defaultTerms : yes ; .. >, 't) base_gexpr
|
||||
| EEmptyError : ('a, < defaultTerms : yes ; .. >, 't) base_gexpr
|
||||
-> ('a, < defaultTerms : yes ; .. >, 'm) base_gexpr
|
||||
| EEmptyError : ('a, < defaultTerms : yes ; .. >, 'm) base_gexpr
|
||||
| EErrorOnEmpty :
|
||||
('a, 't) gexpr
|
||||
-> ('a, < defaultTerms : yes ; .. >, 't) base_gexpr
|
||||
('a, 'm) gexpr
|
||||
-> ('a, < defaultTerms : yes ; .. >, 'm) base_gexpr
|
||||
(* Lambda calculus with exceptions *)
|
||||
| ERaise : except -> ('a, < exceptions : yes ; .. >, 't) base_gexpr
|
||||
| ERaise : except -> ('a, < exceptions : yes ; .. >, 'm) base_gexpr
|
||||
| ECatch : {
|
||||
body : ('a, 't) gexpr;
|
||||
body : ('a, 'm) gexpr;
|
||||
exn : except;
|
||||
handler : ('a, 't) gexpr;
|
||||
handler : ('a, 'm) gexpr;
|
||||
}
|
||||
-> ('a, < exceptions : yes ; .. >, 't) base_gexpr
|
||||
-> ('a, < exceptions : yes ; .. >, 'm) base_gexpr
|
||||
|
||||
(* Useful for errors and printing, for example *)
|
||||
(* type any_expr = AnyExpr : ('a, _ mark) gexpr -> any_expr *)
|
||||
(** Useful for errors and printing, for example *)
|
||||
type any_expr = AnyExpr : ('a, _) gexpr -> any_expr
|
||||
|
||||
type ('a, 't) boxed_gexpr = (('a, 't) naked_gexpr Bindlib.box, 't) Mark.ed
|
||||
type ('a, 'm) boxed_gexpr = (('a, 'm) naked_gexpr Bindlib.box, 'm) marked
|
||||
(** The annotation is lifted outside of the box for expressions *)
|
||||
|
||||
type 'e boxed = ('a, 't) boxed_gexpr constraint 'e = ('a, 't) gexpr
|
||||
(** [('a, 't) gexpr boxed] is [('a, 't) boxed_gexpr]. The difference with
|
||||
[('a, 't) gexpr Bindlib.box] is that the annotations is outside of the box,
|
||||
type 'e boxed = ('a, 'm) boxed_gexpr constraint 'e = ('a, 'm) gexpr
|
||||
(** [('a, 'm) gexpr boxed] is [('a, 'm) boxed_gexpr]. The difference with
|
||||
[('a, 'm) gexpr Bindlib.box] is that the annotations is outside of the box,
|
||||
and can therefore be accessed without the need to resolve the box *)
|
||||
|
||||
type ('e, 'b) binder = (('a, 't) naked_gexpr, 'b) Bindlib.binder
|
||||
constraint 'e = ('a, 't) gexpr
|
||||
type ('e, 'b) binder = (('a, 'm) naked_gexpr, 'b) Bindlib.binder
|
||||
constraint 'e = ('a, 'm) gexpr
|
||||
(** The expressions use the {{:https://lepigre.fr/ocaml-bindlib/} Bindlib}
|
||||
library, based on higher-order abstract syntax *)
|
||||
|
||||
type ('e, 'b) mbinder = (('a, 't) naked_gexpr, 'b) Bindlib.mbinder
|
||||
constraint 'e = ('a, 't) gexpr
|
||||
|
||||
(** {2 Markings} *)
|
||||
|
||||
type untyped = { pos : Pos.t } [@@ocaml.unboxed]
|
||||
type typed = { pos : Pos.t; ty : typ }
|
||||
|
||||
(** The generic type of AST markings. Using a GADT allows functions to be
|
||||
polymorphic in the marking, but still do transformations on types when
|
||||
appropriate. Expected to fill the ['t] parameter of [gexpr] and [gexpr] (a
|
||||
['t] annotation different from this type is used in the middle of the typing
|
||||
processing, but all visible ASTs should otherwise use this. *)
|
||||
type _ mark = Untyped : untyped -> untyped mark | Typed : typed -> typed mark
|
||||
|
||||
(** Useful for errors and printing, for example *)
|
||||
type any_expr = AnyExpr : ('a, _ mark) gexpr -> any_expr
|
||||
type ('e, 'b) mbinder = (('a, 'm) naked_gexpr, 'b) Bindlib.mbinder
|
||||
constraint 'e = ('a, 'm) gexpr
|
||||
|
||||
(** {2 Higher-level program structure} *)
|
||||
|
||||
@ -496,7 +499,7 @@ type 'e scope_let = {
|
||||
(* todo ? Factorise the code_item _list type below and use it here *)
|
||||
scope_let_pos : Pos.t;
|
||||
}
|
||||
constraint 'e = ('a any, _ mark) gexpr
|
||||
constraint 'e = ('a any, _) gexpr
|
||||
(** This type is parametrized by the expression type so it can be reused in
|
||||
later intermediate representations. *)
|
||||
|
||||
@ -506,14 +509,14 @@ type 'e scope_let = {
|
||||
and 'e scope_body_expr =
|
||||
| Result of 'e
|
||||
| ScopeLet of 'e scope_let
|
||||
constraint 'e = ('a any, _ mark) gexpr
|
||||
constraint 'e = ('a any, _) gexpr
|
||||
|
||||
type 'e scope_body = {
|
||||
scope_body_input_struct : StructName.t;
|
||||
scope_body_output_struct : StructName.t;
|
||||
scope_body_expr : ('e, 'e scope_body_expr) binder;
|
||||
}
|
||||
constraint 'e = ('a any, _ mark) gexpr
|
||||
constraint 'e = ('a any, _) gexpr
|
||||
(** Instead of being a single expression, we give a little more ad-hoc structure
|
||||
to the scope body by decomposing it in an ordered list of let-bindings, and
|
||||
a result expression that uses the let-binded variables. The first binder is
|
||||
|
||||
@ -174,24 +174,25 @@ let escopecall scope args mark =
|
||||
let no_mark : type m. m mark -> m mark = function
|
||||
| Untyped _ -> Untyped { pos = Pos.no_pos }
|
||||
| Typed _ -> Typed { pos = Pos.no_pos; ty = Mark.add Pos.no_pos TAny }
|
||||
| Custom { custom; pos = _ } -> Custom { pos = Pos.no_pos; custom }
|
||||
|
||||
let mark_pos (type m) (m : m mark) : Pos.t =
|
||||
match m with Untyped { pos } | Typed { pos; _ } -> pos
|
||||
match m with Untyped { pos } | Typed { pos; _ } | Custom { pos; _ } -> pos
|
||||
|
||||
let pos (type m) (x : ('a, m mark) Mark.ed) : Pos.t = mark_pos (Mark.get x)
|
||||
let pos (type m) (x : ('a, m) marked) : Pos.t = mark_pos (Mark.get x)
|
||||
|
||||
let fun_id mark : ('a any, 'm mark) boxed_gexpr =
|
||||
let fun_id mark : ('a any, 'm) boxed_gexpr =
|
||||
let x = Var.make "x" in
|
||||
eabs (bind [| x |] (evar x mark)) [TAny, mark_pos mark] mark
|
||||
|
||||
let ty (_, m) : typ = match m with Typed { ty; _ } -> ty
|
||||
|
||||
let set_ty (type m) (ty : typ) (x : ('a, m mark) Mark.ed) :
|
||||
('a, typed mark) Mark.ed =
|
||||
let set_ty (type m) (ty : typ) (x : ('a, m) marked) : ('a, typed) marked =
|
||||
Mark.add
|
||||
(match Mark.get x with
|
||||
| Untyped { pos } -> Typed { pos; ty }
|
||||
| Typed m -> Typed { m with ty })
|
||||
| Typed m -> Typed { m with ty }
|
||||
| Custom { pos; _ } -> Typed { pos; ty })
|
||||
(Mark.remove x)
|
||||
|
||||
let map_mark (type m) (pos_f : Pos.t -> Pos.t) (ty_f : typ -> typ) (m : m mark)
|
||||
@ -199,6 +200,7 @@ let map_mark (type m) (pos_f : Pos.t -> Pos.t) (ty_f : typ -> typ) (m : m mark)
|
||||
match m with
|
||||
| Untyped { pos } -> Untyped { pos = pos_f pos }
|
||||
| Typed { pos; ty } -> Typed { pos = pos_f pos; ty = ty_f ty }
|
||||
| Custom { pos; custom } -> Custom { pos = pos_f pos; custom }
|
||||
|
||||
let map_mark2
|
||||
(type m)
|
||||
@ -209,6 +211,7 @@ let map_mark2
|
||||
match m1, m2 with
|
||||
| Untyped m1, Untyped m2 -> Untyped { pos = pos_f m1.pos m2.pos }
|
||||
| Typed m1, Typed m2 -> Typed { pos = pos_f m1.pos m2.pos; ty = ty_f m1 m2 }
|
||||
| Custom _, Custom _ -> invalid_arg "map_mark2"
|
||||
|
||||
let fold_marks
|
||||
(type m)
|
||||
@ -225,6 +228,7 @@ let fold_marks
|
||||
pos = pos_f (List.map (function Typed { pos; _ } -> pos) ms);
|
||||
ty = ty_f (List.map (function Typed m -> m) ms);
|
||||
}
|
||||
| Custom _ :: _ -> invalid_arg "map_mark2"
|
||||
|
||||
let with_pos (type m) (pos : Pos.t) (m : m mark) : m mark =
|
||||
map_mark (fun _ -> pos) (fun ty -> ty) m
|
||||
@ -236,7 +240,9 @@ let with_ty (type m) (m : m mark) ?pos (ty : typ) : m mark =
|
||||
map_mark (fun default -> Option.value pos ~default) (fun _ -> ty) m
|
||||
|
||||
let maybe_ty (type m) ?(typ = TAny) (m : m mark) : typ =
|
||||
match m with Untyped { pos } -> Mark.add pos typ | Typed { ty; _ } -> ty
|
||||
match m with
|
||||
| Untyped { pos } | Custom { pos; _ } -> Mark.add pos typ
|
||||
| Typed { ty; _ } -> ty
|
||||
|
||||
(* - Predefined types (option) - *)
|
||||
|
||||
@ -254,7 +260,7 @@ let option_enum_config =
|
||||
let map
|
||||
(type a b)
|
||||
~(f : (a, 'm1) gexpr -> (b, 'm2) boxed_gexpr)
|
||||
(e : ((a, b, 'm1) base_gexpr, 'm2) Mark.ed) : (b, 'm2) boxed_gexpr =
|
||||
(e : ((a, b, 'm1) base_gexpr, 'm2) marked) : (b, 'm2) boxed_gexpr =
|
||||
let m = Mark.get e in
|
||||
match Mark.remove e with
|
||||
| ELit l -> elit l m
|
||||
@ -294,9 +300,7 @@ let map
|
||||
escopecall scope fields m
|
||||
|
||||
let rec map_top_down ~f e = map ~f:(map_top_down ~f) (f e)
|
||||
|
||||
let map_marks ~f e =
|
||||
map_top_down ~f:(Mark.map_mark f) e
|
||||
let map_marks ~f e = map_top_down ~f:(Mark.map_mark f) e
|
||||
|
||||
(* Folds the given function on the direct children of the given expression. *)
|
||||
let shallow_fold
|
||||
@ -333,7 +337,7 @@ let map_gather
|
||||
~(acc : 'acc)
|
||||
~(join : 'acc -> 'acc -> 'acc)
|
||||
~(f : (a, 'm1) gexpr -> 'acc * (a, 'm2) boxed_gexpr)
|
||||
(e : ((a, 'm1) naked_gexpr, 'm2) Mark.ed) : 'acc * (a, 'm2) boxed_gexpr =
|
||||
(e : ((a, 'm1) naked_gexpr, 'm2) marked) : 'acc * (a, 'm2) boxed_gexpr =
|
||||
let m = Mark.get e in
|
||||
let lfoldmap es =
|
||||
let acc, r_es =
|
||||
|
||||
@ -22,130 +22,134 @@ open Definitions
|
||||
|
||||
(** {2 Boxed constructors} *)
|
||||
|
||||
val box : ('a, 't) gexpr -> ('a, 't) boxed_gexpr
|
||||
val box : ('a, 'm) gexpr -> ('a, 'm) boxed_gexpr
|
||||
(** Box the expression from the outside *)
|
||||
|
||||
val unbox : ('a, 't) boxed_gexpr -> ('a, 't) gexpr
|
||||
val unbox : ('a, 'm) boxed_gexpr -> ('a, 'm) gexpr
|
||||
(** For closed expressions, similar to [Bindlib.unbox] *)
|
||||
|
||||
val rebox : ('a any, 't) gexpr -> ('a, 't) boxed_gexpr
|
||||
val rebox : ('a any, 'm) gexpr -> ('a, 'm) boxed_gexpr
|
||||
(** Rebuild the whole term, re-binding all variables and exposing free variables *)
|
||||
|
||||
val evar : ('a, 't) gexpr Var.t -> 't -> ('a, 't) boxed_gexpr
|
||||
val evar : ('a, 'm) gexpr Var.t -> 'm mark -> ('a, 'm) boxed_gexpr
|
||||
|
||||
val bind :
|
||||
('a, 't) gexpr Var.t array ->
|
||||
('a, 't) boxed_gexpr ->
|
||||
(('a, 't) naked_gexpr, ('a, 't) gexpr) Bindlib.mbinder Bindlib.box
|
||||
('a, 'm) gexpr Var.t array ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
(('a, 'm) naked_gexpr, ('a, 'm) gexpr) Bindlib.mbinder Bindlib.box
|
||||
|
||||
val subst :
|
||||
(('a, 't) naked_gexpr, ('a, 't) gexpr) Bindlib.mbinder ->
|
||||
('a, 't) gexpr list ->
|
||||
('a, 't) gexpr
|
||||
(('a, 'm) naked_gexpr, ('a, 'm) gexpr) Bindlib.mbinder ->
|
||||
('a, 'm) gexpr list ->
|
||||
('a, 'm) gexpr
|
||||
|
||||
val etuple : ('a, 't) boxed_gexpr list -> 't -> ('a any, 't) boxed_gexpr
|
||||
val etuple : ('a, 'm) boxed_gexpr list -> 'm mark -> ('a any, 'm) boxed_gexpr
|
||||
|
||||
val etupleaccess :
|
||||
('a, 't) boxed_gexpr -> int -> int -> 't -> ('a any, 't) boxed_gexpr
|
||||
('a, 'm) boxed_gexpr -> int -> int -> 'm mark -> ('a any, 'm) boxed_gexpr
|
||||
|
||||
val earray : ('a, 't) boxed_gexpr list -> 't -> ('a any, 't) boxed_gexpr
|
||||
val elit : lit -> 't -> ('a any, 't) boxed_gexpr
|
||||
val earray : ('a, 'm) boxed_gexpr list -> 'm mark -> ('a any, 'm) boxed_gexpr
|
||||
val elit : lit -> 'm mark -> ('a any, 'm) boxed_gexpr
|
||||
|
||||
val eabs :
|
||||
(('a, 't) naked_gexpr, ('a, 't) gexpr) Bindlib.mbinder Bindlib.box ->
|
||||
(('a, 'm) naked_gexpr, ('a, 'm) gexpr) Bindlib.mbinder Bindlib.box ->
|
||||
typ list ->
|
||||
't ->
|
||||
('a any, 't) boxed_gexpr
|
||||
'm mark ->
|
||||
('a any, 'm) boxed_gexpr
|
||||
|
||||
val eapp :
|
||||
('a, 't) boxed_gexpr ->
|
||||
('a, 't) boxed_gexpr list ->
|
||||
't ->
|
||||
('a any, 't) boxed_gexpr
|
||||
('a, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr list ->
|
||||
'm mark ->
|
||||
('a any, 'm) boxed_gexpr
|
||||
|
||||
val eassert :
|
||||
('a, 't) boxed_gexpr ->
|
||||
't ->
|
||||
((< assertions : yes ; .. > as 'a), 't) boxed_gexpr
|
||||
('a, 'm) boxed_gexpr ->
|
||||
'm mark ->
|
||||
((< assertions : yes ; .. > as 'a), 'm) boxed_gexpr
|
||||
|
||||
val eop : 'a operator -> typ list -> 't -> ('a any, 't) boxed_gexpr
|
||||
val eop : 'a operator -> typ list -> 'm mark -> ('a any, 'm) boxed_gexpr
|
||||
|
||||
val edefault :
|
||||
('a, 't) boxed_gexpr list ->
|
||||
('a, 't) boxed_gexpr ->
|
||||
('a, 't) boxed_gexpr ->
|
||||
't ->
|
||||
((< defaultTerms : yes ; .. > as 'a), 't) boxed_gexpr
|
||||
('a, 'm) boxed_gexpr list ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
'm mark ->
|
||||
((< defaultTerms : yes ; .. > as 'a), 'm) boxed_gexpr
|
||||
|
||||
val eifthenelse :
|
||||
('a, 't) boxed_gexpr ->
|
||||
('a, 't) boxed_gexpr ->
|
||||
('a, 't) boxed_gexpr ->
|
||||
't ->
|
||||
('a any, 't) boxed_gexpr
|
||||
('a, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
'm mark ->
|
||||
('a any, 'm) boxed_gexpr
|
||||
|
||||
val eemptyerror : 't -> ((< defaultTerms : yes ; .. > as 'a), 't) boxed_gexpr
|
||||
val eemptyerror :
|
||||
'm mark -> ((< defaultTerms : yes ; .. > as 'a), 'm) boxed_gexpr
|
||||
|
||||
val eerroronempty :
|
||||
('a, 't) boxed_gexpr ->
|
||||
't ->
|
||||
((< defaultTerms : yes ; .. > as 'a), 't) boxed_gexpr
|
||||
('a, 'm) boxed_gexpr ->
|
||||
'm mark ->
|
||||
((< defaultTerms : yes ; .. > as 'a), 'm) boxed_gexpr
|
||||
|
||||
val ecatch :
|
||||
('a, 't) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
except ->
|
||||
('a, 't) boxed_gexpr ->
|
||||
't ->
|
||||
((< exceptions : yes ; .. > as 'a), 't) boxed_gexpr
|
||||
('a, 'm) boxed_gexpr ->
|
||||
'm mark ->
|
||||
((< exceptions : yes ; .. > as 'a), 'm) boxed_gexpr
|
||||
|
||||
val eraise : except -> 't -> (< exceptions : yes ; .. >, 't) boxed_gexpr
|
||||
val elocation : 'a glocation -> 't -> ((< .. > as 'a), 't) boxed_gexpr
|
||||
val eraise : except -> 'm mark -> (< exceptions : yes ; .. >, 'm) boxed_gexpr
|
||||
val elocation : 'a glocation -> 'm mark -> ((< .. > as 'a), 'm) boxed_gexpr
|
||||
|
||||
val estruct :
|
||||
StructName.t ->
|
||||
('a, 't) boxed_gexpr StructField.Map.t ->
|
||||
't ->
|
||||
('a any, 't) boxed_gexpr
|
||||
('a, 'm) boxed_gexpr StructField.Map.t ->
|
||||
'm mark ->
|
||||
('a any, 'm) boxed_gexpr
|
||||
|
||||
val edstructaccess :
|
||||
('a, 't) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
IdentName.t ->
|
||||
StructName.t option ->
|
||||
't ->
|
||||
((< syntacticNames : yes ; .. > as 'a), 't) boxed_gexpr
|
||||
'm mark ->
|
||||
((< syntacticNames : yes ; .. > as 'a), 'm) boxed_gexpr
|
||||
|
||||
val estructaccess :
|
||||
('a, 't) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
StructField.t ->
|
||||
StructName.t ->
|
||||
't ->
|
||||
((< resolvedNames : yes ; .. > as 'a), 't) boxed_gexpr
|
||||
'm mark ->
|
||||
((< resolvedNames : yes ; .. > as 'a), 'm) boxed_gexpr
|
||||
|
||||
val einj :
|
||||
('a, 't) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
EnumConstructor.t ->
|
||||
EnumName.t ->
|
||||
't ->
|
||||
('a any, 't) boxed_gexpr
|
||||
'm mark ->
|
||||
('a any, 'm) boxed_gexpr
|
||||
|
||||
val ematch :
|
||||
('a, 't) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
EnumName.t ->
|
||||
('a, 't) boxed_gexpr EnumConstructor.Map.t ->
|
||||
't ->
|
||||
('a any, 't) boxed_gexpr
|
||||
('a, 'm) boxed_gexpr EnumConstructor.Map.t ->
|
||||
'm mark ->
|
||||
('a any, 'm) boxed_gexpr
|
||||
|
||||
val escopecall :
|
||||
ScopeName.t ->
|
||||
('a, 't) boxed_gexpr ScopeVar.Map.t ->
|
||||
't ->
|
||||
((< explicitScopes : yes ; .. > as 'a), 't) boxed_gexpr
|
||||
('a, 'm) boxed_gexpr ScopeVar.Map.t ->
|
||||
'm mark ->
|
||||
((< explicitScopes : yes ; .. > as 'a), 'm) boxed_gexpr
|
||||
|
||||
val fun_id : 'm mark -> ('a any, 'm mark) boxed_gexpr
|
||||
val fun_id : 'm mark -> ('a any, 'm) boxed_gexpr
|
||||
|
||||
(** {2 Manipulation of marks} *)
|
||||
|
||||
val no_mark : 'm mark -> 'm mark
|
||||
(** Returns an empty mark, using the argument as type witness. Note that the
|
||||
custom part is kept on [Custom] marks *)
|
||||
|
||||
val mark_pos : 'm mark -> Pos.t
|
||||
val with_pos : Pos.t -> 'm mark -> 'm mark
|
||||
|
||||
@ -163,9 +167,11 @@ val map_mark2 :
|
||||
'm mark ->
|
||||
'm mark ->
|
||||
'm mark
|
||||
(** @raise Invalid_arg on custom marks*)
|
||||
|
||||
val fold_marks :
|
||||
(Pos.t list -> Pos.t) -> (typed list -> typ) -> 'm mark list -> 'm mark
|
||||
(** @raise Invalid_arg on custom marks*)
|
||||
|
||||
val maybe_ty : ?typ:naked_typ -> 'm mark -> typ
|
||||
(** Returns the corresponding type on a typed expr, or [typ] (defaulting to
|
||||
@ -180,16 +186,16 @@ val option_enum_config : typ EnumConstructor.Map.t
|
||||
|
||||
(** Manipulation of marked expressions *)
|
||||
|
||||
val pos : ('a, 'm mark) Mark.ed -> Pos.t
|
||||
val ty : ('e, typed mark) Mark.ed -> typ
|
||||
val set_ty : typ -> ('a, 'm mark) Mark.ed -> ('a, typed mark) Mark.ed
|
||||
val untype : ('a, 'm mark) gexpr -> ('a, untyped mark) boxed_gexpr
|
||||
val pos : ('a, 'm) marked -> Pos.t
|
||||
val ty : ('e, typed) marked -> typ
|
||||
val set_ty : typ -> ('a, 'm) marked -> ('a, typed) marked
|
||||
val untype : ('a, 'm) gexpr -> ('a, untyped) boxed_gexpr
|
||||
|
||||
(** {2 Traversal functions} *)
|
||||
|
||||
val map :
|
||||
f:(('a, 'm1) gexpr -> ('b, 'm2) boxed_gexpr) ->
|
||||
(('a, 'b, 'm1) base_gexpr, 'm2) Mark.ed ->
|
||||
(('a, 'b, 'm1) base_gexpr, 'm2) marked ->
|
||||
('b, 'm2) boxed_gexpr
|
||||
(** Shallow mapping on expressions (non recursive): applies the given function
|
||||
to all sub-terms of the given expression, and rebuilds the node.
|
||||
@ -223,17 +229,18 @@ val map :
|
||||
becomes useful. *)
|
||||
|
||||
val map_top_down :
|
||||
f:(('a, 't1) gexpr -> (('a, 't1) naked_gexpr, 't2) Mark.ed) ->
|
||||
('a, 't1) gexpr ->
|
||||
('a, 't2) boxed_gexpr
|
||||
f:(('a, 'm1) gexpr -> (('a, 'm1) naked_gexpr, 'm2) marked) ->
|
||||
('a, 'm1) gexpr ->
|
||||
('a, 'm2) boxed_gexpr
|
||||
(** Recursively applies [f] to the nodes of the expression tree. The type
|
||||
returned by [f] is hybrid since the mark at top-level has been rewritten,
|
||||
but not yet the marks in the subtrees. *)
|
||||
|
||||
val map_marks : f:('t1 -> 't2) -> ('a, 't1) gexpr -> ('a, 't2) boxed_gexpr
|
||||
val map_marks :
|
||||
f:('m1 mark -> 'm2 mark) -> ('a, 'm1) gexpr -> ('a, 'm2) boxed_gexpr
|
||||
|
||||
val shallow_fold :
|
||||
(('a, 't) gexpr -> 'acc -> 'acc) -> ('a, 't) gexpr -> 'acc -> 'acc
|
||||
(('a, 'm) gexpr -> 'acc -> 'acc) -> ('a, 'm) gexpr -> 'acc -> 'acc
|
||||
(** Applies a function on all sub-terms of the given expression. Does not
|
||||
recurse. It opens binders unless you avoid sending binders to the function
|
||||
like the example below. Useful as helper for recursive calls within
|
||||
@ -252,9 +259,9 @@ val shallow_fold :
|
||||
val map_gather :
|
||||
acc:'acc ->
|
||||
join:('acc -> 'acc -> 'acc) ->
|
||||
f:(('a, 't1) gexpr -> 'acc * ('a, 't2) boxed_gexpr) ->
|
||||
(('a, 't1) naked_gexpr, 't2) Mark.ed ->
|
||||
'acc * ('a, 't2) boxed_gexpr
|
||||
f:(('a, 'm1) gexpr -> 'acc * ('a, 'm2) boxed_gexpr) ->
|
||||
(('a, 'm1) naked_gexpr, 'm2) marked ->
|
||||
'acc * ('a, 'm2) boxed_gexpr
|
||||
(** Shallow mapping similar to [map], but additionally allows to gather an
|
||||
accumulator bottom-up. [acc] is the accumulator value returned on terminal
|
||||
nodes, and [join] is used to merge accumulators from the different sub-terms
|
||||
@ -273,52 +280,49 @@ val map_gather :
|
||||
|
||||
(** {2 Expression building helpers} *)
|
||||
|
||||
val make_var : ('a, 't) gexpr Var.t -> 't -> ('a, 't) boxed_gexpr
|
||||
val make_var : ('a, 'm) gexpr Var.t -> 'm mark -> ('a, 'm) boxed_gexpr
|
||||
|
||||
val make_abs :
|
||||
('a, 'm mark) gexpr Var.vars ->
|
||||
('a, 'm mark) boxed_gexpr ->
|
||||
('a, 'm) gexpr Var.vars ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
typ list ->
|
||||
Pos.t ->
|
||||
('a any, 'm mark) boxed_gexpr
|
||||
('a any, 'm) boxed_gexpr
|
||||
|
||||
val make_app :
|
||||
('a any, 'm mark) boxed_gexpr ->
|
||||
('a, 'm mark) boxed_gexpr list ->
|
||||
('a any, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr list ->
|
||||
Pos.t ->
|
||||
('a any, 'm mark) boxed_gexpr
|
||||
('a any, 'm) boxed_gexpr
|
||||
|
||||
val empty_thunked_term :
|
||||
'm mark -> (< defaultTerms : yes ; .. >, 'm mark) boxed_gexpr
|
||||
'm mark -> (< defaultTerms : yes ; .. >, 'm) boxed_gexpr
|
||||
|
||||
val thunk_term :
|
||||
('a any, 'b mark) boxed_gexpr -> 'b mark -> ('a, 'b mark) boxed_gexpr
|
||||
|
||||
val unthunk_term_nobox :
|
||||
('a any, 'm mark) gexpr -> 'm mark -> ('a, 'm mark) gexpr
|
||||
val thunk_term : ('a any, 'b) boxed_gexpr -> 'b mark -> ('a, 'b) boxed_gexpr
|
||||
val unthunk_term_nobox : ('a any, 'm) gexpr -> 'm mark -> ('a, 'm) gexpr
|
||||
|
||||
val make_let_in :
|
||||
('a, 'm mark) gexpr Var.t ->
|
||||
('a, 'm) gexpr Var.t ->
|
||||
typ ->
|
||||
('a, 'm mark) boxed_gexpr ->
|
||||
('a, 'm mark) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
Pos.t ->
|
||||
('a any, 'm mark) boxed_gexpr
|
||||
('a any, 'm) boxed_gexpr
|
||||
|
||||
val make_multiple_let_in :
|
||||
('a, 'm mark) gexpr Var.vars ->
|
||||
('a, 'm) gexpr Var.vars ->
|
||||
typ list ->
|
||||
('a, 'm mark) boxed_gexpr list ->
|
||||
('a, 'm mark) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr list ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
Pos.t ->
|
||||
('a any, 'm mark) boxed_gexpr
|
||||
('a any, 'm) boxed_gexpr
|
||||
|
||||
val make_default :
|
||||
('a, 't) boxed_gexpr list ->
|
||||
('a, 't) boxed_gexpr ->
|
||||
('a, 't) boxed_gexpr ->
|
||||
't ->
|
||||
((< polymorphic : yes ; defaultTerms : yes ; .. > as 'a), 't) boxed_gexpr
|
||||
('a, 'm) boxed_gexpr list ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
'm mark ->
|
||||
((< polymorphic : yes ; defaultTerms : yes ; .. > as 'a), 'm) 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
|
||||
@ -333,7 +337,7 @@ val make_default :
|
||||
[EDefault], is rewritten as [ex] *)
|
||||
|
||||
val make_tuple :
|
||||
('a any, 'm mark) boxed_gexpr list -> 'm mark -> ('a, 'm mark) boxed_gexpr
|
||||
('a any, 'm) boxed_gexpr list -> 'm mark -> ('a, 'm) boxed_gexpr
|
||||
(** Builds a tuple; the mark argument is only used as witness and for position
|
||||
when building 0-uples *)
|
||||
|
||||
@ -343,11 +347,11 @@ val skip_wrappers : ('a, 'm) gexpr -> ('a, 'm) gexpr
|
||||
(** Removes surface logging calls and [EErrorOnEmpty] nodes. Shallow function *)
|
||||
|
||||
val remove_logging_calls :
|
||||
((< polymorphic : yes ; .. > as 'a), 't) gexpr -> ('a, 't) boxed_gexpr
|
||||
((< polymorphic : yes ; .. > as 'a), 'm) gexpr -> ('a, 'm) boxed_gexpr
|
||||
(** Removes all calls to [Log] unary operators in the AST, replacing them by
|
||||
their argument. *)
|
||||
|
||||
val format : Format.formatter -> ('a, 'm mark) gexpr -> unit
|
||||
val format : Format.formatter -> ('a, 'm) gexpr -> unit
|
||||
(** Simple printing without debug, use [Print.expr ()] instead to follow the
|
||||
command-line debug setting *)
|
||||
|
||||
@ -360,17 +364,17 @@ val compare_location : 'a glocation Mark.pos -> 'a glocation Mark.pos -> int
|
||||
val equal_except : except -> except -> bool
|
||||
val compare_except : except -> except -> int
|
||||
|
||||
val equal : ('a, 't) gexpr -> ('a, 't) gexpr -> bool
|
||||
val equal : ('a, 'm) gexpr -> ('a, 'm) gexpr -> bool
|
||||
(** Determines if two expressions are equal, omitting their position information *)
|
||||
|
||||
val compare : ('a, 't) gexpr -> ('a, 't) gexpr -> int
|
||||
val compare : ('a, 'm) gexpr -> ('a, 'm) gexpr -> int
|
||||
(** Standard comparison function, suitable for e.g. [Set.Make]. Ignores position
|
||||
information *)
|
||||
|
||||
val is_value : ('a any, 't) gexpr -> bool
|
||||
val free_vars : ('a any, 't) gexpr -> ('a, 't) gexpr Var.Set.t
|
||||
val is_value : ('a any, 'm) gexpr -> bool
|
||||
val free_vars : ('a any, 'm) gexpr -> ('a, 'm) gexpr Var.Set.t
|
||||
|
||||
val size : ('a, 't) gexpr -> int
|
||||
val size : ('a, 'm) gexpr -> int
|
||||
(** Used by the optimizer to know when to stop *)
|
||||
|
||||
(** {2 Low-level handling of boxed expressions} *)
|
||||
@ -385,11 +389,11 @@ module Box : sig
|
||||
add the annotation outside of the box, and delay its injection (using
|
||||
[lift]) to when the parent term gets built. *)
|
||||
|
||||
val lift : ('a, 't) boxed_gexpr -> ('a, 't) gexpr Bindlib.box
|
||||
val lift : ('a, 'm) boxed_gexpr -> ('a, 'm) gexpr Bindlib.box
|
||||
(** Inject the annotation within the box, to use e.g. when a [gexpr box] is
|
||||
required for building parent terms *)
|
||||
|
||||
val app0 : ('a, 't) naked_gexpr -> 't -> ('a, 't) boxed_gexpr
|
||||
val app0 : ('a, 'm) naked_gexpr -> 'm mark -> ('a, 'm) boxed_gexpr
|
||||
(** The [app*] functions allow building boxed expressions using
|
||||
[Bindlib.apply_box] and its variants, while correctly handling the
|
||||
expression annotations. Note that the function provided as argument should
|
||||
@ -397,49 +401,49 @@ module Box : sig
|
||||
a separate argument. *)
|
||||
|
||||
val app1 :
|
||||
('a, 't1) boxed_gexpr ->
|
||||
(('a, 't1) gexpr -> ('a, 't2) naked_gexpr) ->
|
||||
't2 ->
|
||||
('a, 't2) boxed_gexpr
|
||||
('a, 'm1) boxed_gexpr ->
|
||||
(('a, 'm1) gexpr -> ('a, 'm2) naked_gexpr) ->
|
||||
'm2 mark ->
|
||||
('a, 'm2) boxed_gexpr
|
||||
|
||||
val app2 :
|
||||
('a, 't) boxed_gexpr ->
|
||||
('a, 't) boxed_gexpr ->
|
||||
(('a, 't) gexpr -> ('a, 't) gexpr -> ('a, 't) naked_gexpr) ->
|
||||
't ->
|
||||
('a, 't) boxed_gexpr
|
||||
('a, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
(('a, 'm) gexpr -> ('a, 'm) gexpr -> ('a, 'm) naked_gexpr) ->
|
||||
'm mark ->
|
||||
('a, 'm) boxed_gexpr
|
||||
|
||||
val app3 :
|
||||
('a, 't) boxed_gexpr ->
|
||||
('a, 't) boxed_gexpr ->
|
||||
('a, 't) boxed_gexpr ->
|
||||
(('a, 't) gexpr -> ('a, 't) gexpr -> ('a, 't) gexpr -> ('a, 't) naked_gexpr) ->
|
||||
't ->
|
||||
('a, 't) boxed_gexpr
|
||||
('a, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
(('a, 'm) gexpr -> ('a, 'm) gexpr -> ('a, 'm) gexpr -> ('a, 'm) naked_gexpr) ->
|
||||
'm mark ->
|
||||
('a, 'm) boxed_gexpr
|
||||
|
||||
val appn :
|
||||
('a, 't) boxed_gexpr list ->
|
||||
(('a, 't) gexpr list -> ('a, 't) naked_gexpr) ->
|
||||
't ->
|
||||
('a, 't) boxed_gexpr
|
||||
('a, 'm) boxed_gexpr list ->
|
||||
(('a, 'm) gexpr list -> ('a, 'm) naked_gexpr) ->
|
||||
'm mark ->
|
||||
('a, 'm) boxed_gexpr
|
||||
|
||||
val app1n :
|
||||
('a, 't) boxed_gexpr ->
|
||||
('a, 't) boxed_gexpr list ->
|
||||
(('a, 't) gexpr -> ('a, 't) gexpr list -> ('a, 't) naked_gexpr) ->
|
||||
't ->
|
||||
('a, 't) boxed_gexpr
|
||||
('a, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr list ->
|
||||
(('a, 'm) gexpr -> ('a, 'm) gexpr list -> ('a, 'm) naked_gexpr) ->
|
||||
'm mark ->
|
||||
('a, 'm) boxed_gexpr
|
||||
|
||||
val app2n :
|
||||
('a, 't) boxed_gexpr ->
|
||||
('a, 't) boxed_gexpr ->
|
||||
('a, 't) boxed_gexpr list ->
|
||||
(('a, 't) gexpr ->
|
||||
('a, 't) gexpr ->
|
||||
('a, 't) gexpr list ->
|
||||
('a, 't) naked_gexpr) ->
|
||||
't ->
|
||||
('a, 't) boxed_gexpr
|
||||
('a, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr ->
|
||||
('a, 'm) boxed_gexpr list ->
|
||||
(('a, 'm) gexpr ->
|
||||
('a, 'm) gexpr ->
|
||||
('a, 'm) gexpr list ->
|
||||
('a, 'm) naked_gexpr) ->
|
||||
'm mark ->
|
||||
('a, 'm) boxed_gexpr
|
||||
|
||||
val fv : 'b Bindlib.box -> string list
|
||||
(** [fv] return the list of free variables from a boxed term. *)
|
||||
|
||||
@ -21,11 +21,11 @@ open Catala_utils
|
||||
open Definitions
|
||||
|
||||
val evaluate_operator :
|
||||
((((_, _) dcalc_lcalc as 'a), 'm mark) gexpr -> ('a, 'm mark) gexpr) ->
|
||||
((((_, _) dcalc_lcalc as 'a), 'm) gexpr -> ('a, 'm) gexpr) ->
|
||||
'a operator ->
|
||||
'm mark ->
|
||||
('a, 'm mark) gexpr list ->
|
||||
('a, 'm mark) gexpr
|
||||
('a, 'm) gexpr list ->
|
||||
('a, 'm) gexpr
|
||||
(** Evaluates the result of applying the given operator to the given arguments,
|
||||
which are expected to be already reduced to values. The first argument is
|
||||
used to evaluate expressions and called when reducing e.g. the [map]
|
||||
@ -33,23 +33,23 @@ val evaluate_operator :
|
||||
|
||||
val evaluate_expr :
|
||||
decl_ctx ->
|
||||
(('a, 'b) dcalc_lcalc, 'm mark) gexpr ->
|
||||
(('a, 'b) dcalc_lcalc, 'm mark) gexpr
|
||||
(('a, 'b) dcalc_lcalc, 'm) gexpr ->
|
||||
(('a, 'b) dcalc_lcalc, 'm) gexpr
|
||||
(** Evaluates an expression according to the semantics of the default calculus. *)
|
||||
|
||||
val interpret_program_dcalc :
|
||||
(dcalc, 'm mark) gexpr program ->
|
||||
(dcalc, 'm) gexpr program ->
|
||||
ScopeName.t ->
|
||||
(Uid.MarkedString.info * (dcalc, 'm mark) gexpr) list
|
||||
(Uid.MarkedString.info * (dcalc, 'm) gexpr) list
|
||||
(** Interprets a program. This function expects an expression typed as a
|
||||
function whose argument are all thunked. The function is executed by
|
||||
providing for each argument a thunked empty default. Returns a list of all
|
||||
the computed values for the scope variables of the executed scope. *)
|
||||
|
||||
val interpret_program_lcalc :
|
||||
(lcalc, 'm mark) gexpr program ->
|
||||
(lcalc, 'm) gexpr program ->
|
||||
ScopeName.t ->
|
||||
(Uid.MarkedString.info * (lcalc, 'm mark) gexpr) list
|
||||
(Uid.MarkedString.info * (lcalc, 'm) gexpr) list
|
||||
(** Interprets a program. This function expects an expression typed as a
|
||||
function whose argument are all thunked. The function is executed by
|
||||
providing for each argument a thunked empty default. Returns a list of all
|
||||
|
||||
@ -19,8 +19,8 @@ open Definitions
|
||||
|
||||
type ('a, 'b, 'm) optimizations_ctx = {
|
||||
var_values :
|
||||
( (('a, 'b) dcalc_lcalc, 'm mark) gexpr,
|
||||
(('a, 'b) dcalc_lcalc, 'm mark) gexpr )
|
||||
( (('a, 'b) dcalc_lcalc, 'm) gexpr,
|
||||
(('a, 'b) dcalc_lcalc, 'm) gexpr )
|
||||
Var.Map.t;
|
||||
decl_ctx : decl_ctx;
|
||||
}
|
||||
@ -61,14 +61,14 @@ let all_match_cases_map_to_same_constructor cases n =
|
||||
let rec optimize_expr :
|
||||
type a b.
|
||||
(a, b, 'm) optimizations_ctx ->
|
||||
((a, b) dcalc_lcalc, 'm mark) gexpr ->
|
||||
((a, b) dcalc_lcalc, 'm mark) boxed_gexpr =
|
||||
((a, b) dcalc_lcalc, 'm) gexpr ->
|
||||
((a, b) dcalc_lcalc, 'm) boxed_gexpr =
|
||||
fun ctx e ->
|
||||
(* We proceed bottom-up, first apply on the subterms *)
|
||||
let e = Expr.map ~f:(optimize_expr ctx) e in
|
||||
let mark = Mark.get e in
|
||||
(* Then reduce the parent node *)
|
||||
let reduce (e : ((a, b) dcalc_lcalc, 'm mark) gexpr) =
|
||||
let reduce (e : ((a, b) dcalc_lcalc, 'm) gexpr) =
|
||||
(* Todo: improve the handling of eapp(log,elit) cases here, it obfuscates
|
||||
the matches and the log calls are not preserved, which would be a good
|
||||
property *)
|
||||
@ -302,9 +302,7 @@ let rec optimize_expr :
|
||||
in
|
||||
Expr.Box.app1 e reduce mark
|
||||
|
||||
let optimize_expr
|
||||
(decl_ctx : decl_ctx)
|
||||
(e : (('a, 'b) dcalc_lcalc, 'm mark) gexpr) =
|
||||
let optimize_expr (decl_ctx : decl_ctx) (e : (('a, 'b) dcalc_lcalc, 'm) gexpr) =
|
||||
optimize_expr { var_values = Var.Map.empty; decl_ctx } e
|
||||
|
||||
let optimize_program (p : 'm program) : 'm program =
|
||||
|
||||
@ -22,12 +22,12 @@ open Definitions
|
||||
|
||||
val optimize_expr :
|
||||
decl_ctx ->
|
||||
(('a, 'b) dcalc_lcalc, 'm mark) gexpr ->
|
||||
(('a, 'b) dcalc_lcalc, 'm mark) boxed_gexpr
|
||||
(('a, 'b) dcalc_lcalc, 'm) gexpr ->
|
||||
(('a, 'b) dcalc_lcalc, 'm) boxed_gexpr
|
||||
|
||||
val optimize_program :
|
||||
(('a, 'b) dcalc_lcalc, 'm mark) gexpr program ->
|
||||
(('a, 'b) dcalc_lcalc, 'm mark) gexpr program
|
||||
(('a, 'b) dcalc_lcalc, 'm) gexpr program ->
|
||||
(('a, 'b) dcalc_lcalc, 'm) gexpr program
|
||||
|
||||
(** {1 Tests}*)
|
||||
|
||||
|
||||
@ -56,7 +56,7 @@ val expr :
|
||||
?debug:bool ->
|
||||
unit ->
|
||||
Format.formatter ->
|
||||
('a, 'm mark) gexpr ->
|
||||
('a, 'm) gexpr ->
|
||||
unit
|
||||
(** Same as [expr], but with a debug flag that defaults to [!Cli.debug_flag]. If
|
||||
[~hide_function_body:true], prints "<function>" for [EAbs] nodes *)
|
||||
@ -69,8 +69,7 @@ val scope :
|
||||
?debug:bool ->
|
||||
decl_ctx ->
|
||||
Format.formatter ->
|
||||
ScopeName.t * ('a, 'm mark) gexpr scope_body ->
|
||||
ScopeName.t * ('a, 'm) gexpr scope_body ->
|
||||
unit
|
||||
|
||||
val program :
|
||||
?debug:bool -> Format.formatter -> ('a, 'm mark) gexpr program -> unit
|
||||
val program : ?debug:bool -> Format.formatter -> ('a, 'm) gexpr program -> unit
|
||||
|
||||
@ -40,8 +40,7 @@ let get_scope_body { code_items; _ } scope =
|
||||
| None -> raise Not_found
|
||||
| Some body -> body
|
||||
|
||||
let untype : 'm. ('a, 'm mark) gexpr program -> ('a, untyped mark) gexpr program
|
||||
=
|
||||
let untype : 'm. ('a, 'm) gexpr program -> ('a, untyped) gexpr program =
|
||||
fun prg -> Bindlib.unbox (map_exprs ~f:Expr.untype ~varf:Var.translate prg)
|
||||
|
||||
let rec find_scope name vars = function
|
||||
|
||||
@ -34,7 +34,7 @@ val fold_right_exprs :
|
||||
val get_scope_body :
|
||||
((_ any, 't) gexpr as 'e) program -> ScopeName.t -> 'e scope_body
|
||||
|
||||
val untype : ('a any, _ mark) gexpr program -> ('a, untyped mark) gexpr program
|
||||
val untype : ('a any, _) gexpr program -> ('a, untyped) gexpr program
|
||||
|
||||
val to_expr : ((_ any, _) gexpr as 'e) program -> ScopeName.t -> 'e boxed
|
||||
(** Usage: [build_whole_program_expr program main_scope] builds an expression
|
||||
|
||||
@ -168,8 +168,8 @@ let build_typ_from_sig
|
||||
|
||||
type 'e scope_name_or_var = ScopeName of ScopeName.t | ScopeVar of 'e Var.t
|
||||
|
||||
let to_expr (ctx : decl_ctx) (body : 'e scope_body) (mark_scope : 'm mark) :
|
||||
'e boxed =
|
||||
let to_expr (ctx : decl_ctx) (body : 'e scope_body) (mark_scope : 'm) : 'e boxed
|
||||
=
|
||||
let var, body_expr = Bindlib.unbind body.scope_body_expr in
|
||||
let body_expr = unfold_body_expr ctx body_expr in
|
||||
Expr.make_abs [| var |] body_expr
|
||||
|
||||
@ -107,15 +107,12 @@ val map_exprs :
|
||||
(** This is the main map visitor for all the expressions inside all the scopes
|
||||
of the program. *)
|
||||
|
||||
val get_body_mark : (_, 'm mark) gexpr scope_body -> 'm mark
|
||||
val get_body_mark : (_, 'm) gexpr scope_body -> 'm mark
|
||||
|
||||
(** {2 Conversions} *)
|
||||
|
||||
val to_expr :
|
||||
decl_ctx ->
|
||||
('a any, 'm mark) gexpr scope_body ->
|
||||
'm mark ->
|
||||
('a, 'm mark) boxed_gexpr
|
||||
decl_ctx -> ('a any, 'm) gexpr scope_body -> 'm mark -> ('a, 'm) boxed_gexpr
|
||||
(** Usage: [to_expr ctx body scope_position] where [scope_position] corresponds
|
||||
to the line of the scope declaration for instance. *)
|
||||
|
||||
@ -123,7 +120,7 @@ type 'e scope_name_or_var = ScopeName of ScopeName.t | ScopeVar of 'e Var.t
|
||||
|
||||
val unfold :
|
||||
decl_ctx ->
|
||||
((_, 'm mark) gexpr as 'e) code_item_list ->
|
||||
((_, 'm) gexpr as 'e) code_item_list ->
|
||||
'm mark ->
|
||||
'e scope_name_or_var ->
|
||||
'e boxed
|
||||
|
||||
@ -17,7 +17,7 @@ irrelevant cases, so that e.g. [(dcalc, _) naked_gexpr] doesn't have the [ERaise
|
||||
[ECatch] cases, while [(lcalc, _) naked_gexpr] doesn't have [EDefault].
|
||||
|
||||
For example, Lcalc expressions are then defined as
|
||||
[type 'm naked_expr = (Shared_ast.lcalc, 'm mark) Shared_ast.naked_gexpr].
|
||||
[type 'm naked_expr = (Shared_ast.lcalc, 'm) Shared_ast.naked_gexpr].
|
||||
|
||||
This makes it possible to write a single function that works on the different
|
||||
ASTs, by having it take a [('a, _) naked_gexpr] as input, while retaining a much
|
||||
|
||||
@ -130,13 +130,11 @@ let rec format_typ
|
||||
|
||||
exception Type_error of A.any_expr * unionfind_typ * unionfind_typ
|
||||
|
||||
type mark = { pos : Pos.t; uf : unionfind_typ }
|
||||
|
||||
(** Raises an error if unification cannot be performed. The position annotation
|
||||
of the second [unionfind_typ] argument is propagated (unless it is [TAny]). *)
|
||||
let rec unify
|
||||
(ctx : A.decl_ctx)
|
||||
(e : ('a, 'm A.mark) A.gexpr) (* used for error context *)
|
||||
(e : ('a, 'm) A.gexpr) (* used for error context *)
|
||||
(t1 : unionfind_typ)
|
||||
(t2 : unionfind_typ) : unit =
|
||||
let unify = unify ctx in
|
||||
@ -172,14 +170,9 @@ let rec unify
|
||||
(fun t1 t2 -> match Mark.remove t2 with TAny _ -> t1 | _ -> t2)
|
||||
t1 t2
|
||||
|
||||
let handle_type_error ctx e t1 t2 =
|
||||
let handle_type_error ctx (A.AnyExpr e) t1 t2 =
|
||||
(* TODO: if we get weird error messages, then it means that we should use the
|
||||
persistent version of the union-find data structure. *)
|
||||
let pos =
|
||||
match e with
|
||||
| A.AnyExpr e -> (
|
||||
match Mark.get e with A.Untyped { pos } -> pos | Typed { pos; _ } -> pos)
|
||||
in
|
||||
let t1_repr = UnionFind.get (UnionFind.find t1) in
|
||||
let t2_repr = UnionFind.get (UnionFind.find t2) in
|
||||
let t1_pos = Mark.get t1_repr in
|
||||
@ -204,7 +197,7 @@ let handle_type_error ctx e t1 t2 =
|
||||
( Some
|
||||
(Format.asprintf
|
||||
"Error coming from typechecking the following expression:"),
|
||||
pos );
|
||||
Expr.pos e );
|
||||
Some (Format.asprintf "Type %a coming from expression:" t1_s ()), t1_pos;
|
||||
Some (Format.asprintf "Type %a coming from expression:" t2_s ()), t2_pos;
|
||||
]
|
||||
@ -336,16 +329,18 @@ module Env = struct
|
||||
end
|
||||
|
||||
let add_pos e ty = Mark.add (Expr.pos e) ty
|
||||
let ty (_, { uf; _ }) = uf
|
||||
|
||||
let ty : (_, unionfind_typ A.custom) A.marked -> unionfind_typ =
|
||||
fun (_, A.Custom { A.custom; _ }) -> custom
|
||||
|
||||
(** Infers the most permissive type from an expression *)
|
||||
let rec typecheck_expr_bottom_up :
|
||||
type a m.
|
||||
leave_unresolved:bool ->
|
||||
A.decl_ctx ->
|
||||
(a, m A.mark) A.gexpr Env.t ->
|
||||
(a, m A.mark) A.gexpr ->
|
||||
(a, mark) A.boxed_gexpr =
|
||||
(a, m) A.gexpr Env.t ->
|
||||
(a, m) A.gexpr ->
|
||||
(a, unionfind_typ A.custom) A.boxed_gexpr =
|
||||
fun ~leave_unresolved ctx env e ->
|
||||
typecheck_expr_top_down ~leave_unresolved ctx env
|
||||
(UnionFind.make (add_pos e (TAny (Any.fresh ()))))
|
||||
@ -356,10 +351,10 @@ and typecheck_expr_top_down :
|
||||
type a m.
|
||||
leave_unresolved:bool ->
|
||||
A.decl_ctx ->
|
||||
(a, m A.mark) A.gexpr Env.t ->
|
||||
(a, m) A.gexpr Env.t ->
|
||||
unionfind_typ ->
|
||||
(a, m A.mark) A.gexpr ->
|
||||
(a, mark) A.boxed_gexpr =
|
||||
(a, m) A.gexpr ->
|
||||
(a, unionfind_typ A.custom) A.boxed_gexpr =
|
||||
fun ~leave_unresolved ctx env tau e ->
|
||||
(* Cli.debug_format "Propagating type %a for naked_expr %a" (format_typ ctx)
|
||||
tau (Expr.format ctx) e; *)
|
||||
@ -370,12 +365,13 @@ and typecheck_expr_top_down :
|
||||
match Mark.get e with
|
||||
| A.Untyped _ | A.Typed { A.ty = A.TAny, _; _ } -> ()
|
||||
| A.Typed { A.ty; _ } -> unify ctx e tau (ast_to_typ ty)
|
||||
| A.Custom _ -> assert false
|
||||
in
|
||||
let context_mark = { uf = tau; pos = pos_e } in
|
||||
let context_mark = A.Custom { A.custom = tau; pos = pos_e } in
|
||||
let mark_with_tau_and_unify uf =
|
||||
(* Unify with the supplied type first, and return the mark *)
|
||||
unify ctx e uf tau;
|
||||
{ uf; pos = pos_e }
|
||||
A.Custom { A.custom = uf; pos = pos_e }
|
||||
in
|
||||
let unionfind ?(pos = e) t = UnionFind.make (add_pos pos t) in
|
||||
let ty_mark ty = mark_with_tau_and_unify (unionfind ty) in
|
||||
@ -472,7 +468,8 @@ and typecheck_expr_top_down :
|
||||
let candidate_structs =
|
||||
try A.IdentName.Map.find field ctx.ctx_struct_fields
|
||||
with Not_found ->
|
||||
Errors.raise_spanned_error context_mark.pos
|
||||
Errors.raise_spanned_error
|
||||
(Expr.mark_pos context_mark)
|
||||
"Field %a does not belong to structure %a (no structure defines \
|
||||
it)"
|
||||
(Cli.format_with_style [ANSITerminal.yellow])
|
||||
@ -482,7 +479,8 @@ and typecheck_expr_top_down :
|
||||
in
|
||||
try A.StructName.Map.find name candidate_structs
|
||||
with Not_found ->
|
||||
Errors.raise_spanned_error context_mark.pos
|
||||
Errors.raise_spanned_error
|
||||
(Expr.mark_pos context_mark)
|
||||
"Field %a does not belong to structure %a, but to %a"
|
||||
(Cli.format_with_style [ANSITerminal.yellow])
|
||||
("\"" ^ field ^ "\"")
|
||||
@ -755,7 +753,7 @@ and typecheck_expr_top_down :
|
||||
unify ctx e t_ret
|
||||
(resolve_overload_ret_type ~leave_unresolved ctx e op tys');
|
||||
( List.map (typ_to_ast ~leave_unresolved) tys',
|
||||
{ uf = t_func; pos = pos_e } ))
|
||||
A.Custom { A.custom = t_func; pos = pos_e } ))
|
||||
~resolved:(fun op ->
|
||||
let mark =
|
||||
mark_with_tau_and_unify
|
||||
@ -818,7 +816,7 @@ let wrap_expr ctx f e =
|
||||
|
||||
(** {1 API} *)
|
||||
|
||||
let get_ty_mark ~leave_unresolved { uf; pos } =
|
||||
let get_ty_mark ~leave_unresolved (A.Custom { A.custom = uf; pos }) =
|
||||
A.Typed { ty = typ_to_ast ~leave_unresolved uf; pos }
|
||||
|
||||
let expr_raw
|
||||
@ -827,7 +825,7 @@ let expr_raw
|
||||
(ctx : A.decl_ctx)
|
||||
?(env = Env.empty ctx)
|
||||
?(typ : A.typ option)
|
||||
(e : (a, 'm) A.gexpr) : (a, mark) A.gexpr =
|
||||
(e : (a, 'm) A.gexpr) : (a, unionfind_typ A.custom) A.gexpr =
|
||||
let fty =
|
||||
match typ with
|
||||
| None -> typecheck_expr_bottom_up ~leave_unresolved ctx env
|
||||
@ -838,7 +836,7 @@ let expr_raw
|
||||
|
||||
let check_expr ~leave_unresolved ctx ?env ?typ e =
|
||||
Expr.map_marks
|
||||
~f:(fun { pos; _ } -> A.Untyped { pos })
|
||||
~f:(fun (Custom { pos; _ }) -> A.Untyped { pos })
|
||||
(expr_raw ctx ~leave_unresolved ?env ?typ e)
|
||||
|
||||
(* Infer the type of an expression *)
|
||||
@ -922,7 +920,7 @@ let rec scopes ~leave_unresolved ctx env = function
|
||||
Bindlib.box_apply (fun body -> A.ScopeDef (name, body)) body_e )
|
||||
| A.Topdef (name, typ, e) ->
|
||||
let e' = expr_raw ~leave_unresolved ctx ~env ~typ e in
|
||||
let uf = (Mark.get e').uf in
|
||||
let (A.Custom { custom = uf; _ }) = Mark.get e' in
|
||||
let e' = Expr.map_marks ~f:(get_ty_mark ~leave_unresolved) e' in
|
||||
( Env.add var uf env,
|
||||
Bindlib.box_apply
|
||||
|
||||
@ -40,8 +40,8 @@ val expr :
|
||||
decl_ctx ->
|
||||
?env:'e Env.t ->
|
||||
?typ:typ ->
|
||||
(('a, 'm mark) gexpr as 'e) ->
|
||||
('a, typed mark) boxed_gexpr
|
||||
(('a, 'm) gexpr as 'e) ->
|
||||
('a, typed) boxed_gexpr
|
||||
(** Infers and marks the types for the given expression. If [typ] is provided,
|
||||
it is assumed to be the outer type and used for inference top-down.
|
||||
|
||||
@ -56,17 +56,15 @@ val check_expr :
|
||||
decl_ctx ->
|
||||
?env:'e Env.t ->
|
||||
?typ:typ ->
|
||||
(('a, 'm mark) gexpr as 'e) ->
|
||||
('a, untyped mark) boxed_gexpr
|
||||
(('a, 'm) gexpr as 'e) ->
|
||||
('a, untyped) boxed_gexpr
|
||||
(** Same as [expr], but doesn't annotate the returned expression. Equivalent to
|
||||
[Typing.expr |> Expr.untype], but more efficient. This can be useful for
|
||||
type-checking and disambiguation (some AST nodes are updated with missing
|
||||
information, e.g. any [TAny] appearing in the AST is replaced) *)
|
||||
|
||||
val program :
|
||||
leave_unresolved:bool ->
|
||||
('a, 'm mark) gexpr program ->
|
||||
('a, typed mark) gexpr program
|
||||
leave_unresolved:bool -> ('a, 'm) gexpr program -> ('a, typed) gexpr program
|
||||
(** Typing on whole programs (as defined in Shared_ast.program, i.e. for the
|
||||
later dcalc/lcalc stages.
|
||||
|
||||
|
||||
@ -54,8 +54,7 @@ let check_article_expiration
|
||||
"%s %s has expired! Its expiration date is %s according to \
|
||||
LégiFrance.%s"
|
||||
(Mark.remove law_heading.Surface.Ast.law_heading_name)
|
||||
(Pos.to_string
|
||||
(Mark.get law_heading.Surface.Ast.law_heading_name))
|
||||
(Pos.to_string (Mark.get law_heading.Surface.Ast.law_heading_name))
|
||||
(Date.print_tm legifrance_expiration_date)
|
||||
(match new_version with
|
||||
| None -> ""
|
||||
|
||||
Loading…
Reference in New Issue
Block a user