CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-16 14:57:13 +03:00
Code Issues Projects Releases Wiki Activity

Rework and normalise the Marked interface

Browse Source 
The module is renamed to `Mark`, and functions renamed to avoid redundancy:

`Marked.mark` is now `Mark.add`
`Marked.unmark` is now `Mark.remove`
`Marked.map_under_mark` is now simply `Mark.map`
etc.

`Marked.same_mark_as` is replaced by `Mark.copy`, but with the arguments
swapped (which seemed more convenient throughout)

Since a type `Mark.t` would indicate a mark, and to avoid confusion, the type
`Marked.t` is renamed to `Mark.ed` as a shorthand for `Mark.marked` ; this part
can easily be removed if that's too much quirkiness.
This commit is contained in:
Louis Gesbert 2023-05-17 15:44:57 +02:00
parent 558fcb6fef
commit fc531777c0
53 changed files with 980 additions and 1092 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
compiler/catala_utils/marked.ml → compiler/catala_utils/mark.ml
View File

@ -15,65 +15,63 @@
License for the specific language governing permissions and limitations under
the License. *)
type ('a, 'm) t = 'a * 'm
type 'a pos = ('a, Pos.t) t
type ('a, 'm) ed = 'a * 'm
type 'a pos = ('a, Pos.t) ed
let mark m e : ('a, 'm) t = e, m
let unmark ((x, _) : ('a, 'm) t) : 'a = x
let get_mark ((_, x) : ('a, 'm) t) : 'm = x
let map_mark (f : 'm1 -> 'm2) ((a, m) : ('a, 'm1) t) : ('a, 'm2) t = a, f m
let map_under_mark (f : 'a -> 'b) ((x, y) : ('a, 'm) t) : ('b, 'c) t = f x, y
let same_mark_as (x : 'a) ((_, y) : ('b, 'm) t) : ('a, 'm) t = x, y
let unmark_option (x : ('a, 'm) t option) : 'a option =
match x with Some x -> Some (unmark x) | None -> None
let compare (cmp : 'a -> 'a -> int) ((x, _) : ('a, 'm) t) ((y, _) : ('a, 'm) t)
: int =
cmp x y
let add m e = e, m
let remove (x, _) = x
let get (_, x) = x
let map f (x, m) = f x, m
let map_mark f (a, m) = a, f m
let copy (_, m) x = x, m
let fold f (x, _) = f x
let fold2 f (x, _) (y, _) = f x y
let compare cmp a b = fold2 cmp a b
let equal eq a b = fold2 eq a b
class ['self] marked_map =
object (_self : 'self)
constraint
'self = < visit_marked :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) t -> ('a, 'm) t
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) ed -> ('a, 'm) ed
; .. >
method visit_marked
: 'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) t -> ('a, 'm) t =
fun f env x -> same_mark_as (f env (unmark x)) x
: 'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) ed -> ('a, 'm) ed =
fun f env (x, m) -> f env x, m
end
class ['self] marked_iter =
object (_self : 'self)
constraint
'self = < visit_marked :
'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) t -> unit
'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) ed -> unit
; .. >
method visit_marked : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) t -> unit
=
fun f env x -> f env (unmark x)
method visit_marked
: 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) ed -> unit =
fun f env (x, _) -> f env x
end
class ['self] pos_map =
object (_self : 'self)
constraint
'self = < visit_pos :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) t -> ('a, 'm) t
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) ed -> ('a, 'm) ed
; .. >
method visit_pos
: 'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) t -> ('a, 'm) t =
fun f env x -> same_mark_as (f env (unmark x)) x
: 'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) ed -> ('a, 'm) ed =
fun f env (x, m) -> f env x, m
end
class ['self] pos_iter =
object (_self : 'self)
constraint
'self = < visit_pos : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) t -> unit
'self = < visit_pos :
'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) ed -> unit
; .. >
method visit_pos : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) t -> unit =
fun f env x -> f env (unmark x)
method visit_pos : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) ed -> unit =
fun f env (x, _) -> f env x
end

49
compiler/catala_utils/marked.mli → compiler/catala_utils/mark.mli
View File

@ -17,23 +17,28 @@
(** AST node annotations (used for position, type, etc.) *)
type ('a, 'm) t = 'a * 'm
(** Everything related to the source code should keep at least its position
stored, to improve error messages *)
type ('a, 'm) ed = 'a * 'm
(** The type of [Mark.ed] values. Everything related to the source code should
keep at least its position stored, to improve error messages. Typing, etc.
also leverage this. *)
type 'a pos = ('a, Pos.t) t
type 'a pos = ('a, Pos.t) ed
(** The type of marks containing only position information *)
val mark : 'm -> 'a -> ('a, 'm) t
val unmark : ('a, 'm) t -> 'a
val get_mark : ('a, 'm) t -> 'm
val map_mark : ('m1 -> 'm2) -> ('a, 'm1) t -> ('a, 'm2) t
val map_under_mark : ('a -> 'b) -> ('a, 'm) t -> ('b, 'm) t
val same_mark_as : 'a -> ('b, 'm) t -> ('a, 'm) t
val unmark_option : ('a, 'm) t option -> 'a option
val add : 'm -> 'a -> ('a, 'm) ed
val remove : ('a, 'm) ed -> 'a
val get : ('a, 'm) ed -> 'm
val map : ('a -> 'b) -> ('a, 'm) ed -> ('b, 'm) ed
val map_mark : ('m1 -> 'm2) -> ('a, 'm1) ed -> ('a, 'm2) ed
val copy : ('b, 'm) ed -> 'a -> ('a, 'm) ed
val fold : ('a -> 'b) -> ('a, _) ed -> 'b
val fold2 : ('a -> 'a -> 'b) -> ('a, 'm) ed -> ('a, 'm) ed -> 'b
val compare : ('a -> 'a -> int) -> ('a, 'm) t -> ('a, 'm) t -> int
(** Compares two marked values {b ignoring positions} *)
val compare : ('a -> 'a -> int) -> ('a, 'm) ed -> ('a, 'm) ed -> int
(** Compares two marked values {b ignoring marks} *)
val equal : ('a -> 'a -> bool) -> ('a, 'm) ed -> ('a, 'm) ed -> bool
(** Tests equality of two marked values {b ignoring marks} *)
(** Visitors *)
@ -41,39 +46,41 @@ class ['self] marked_map :
object ('self)
constraint
'self = < visit_marked :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) t -> ('a, 'm) t
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) ed -> ('a, 'm) ed
; .. >
method visit_marked :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) t -> ('a, 'm) t
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) ed -> ('a, 'm) ed
end
class ['self] marked_iter :
object ('self)
constraint
'self = < visit_marked :
'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) t -> unit
'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) ed -> unit
; .. >
method visit_marked : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) t -> unit
method visit_marked :
'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) ed -> unit
end
class ['self] pos_map :
object ('self)
constraint
'self = < visit_pos :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) t -> ('a, 'm) t
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) ed -> ('a, 'm) ed
; .. >
method visit_pos :
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) t -> ('a, 'm) t
'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) ed -> ('a, 'm) ed
end
class ['self] pos_iter :
object ('self)
constraint
'self = < visit_pos : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) t -> unit
'self = < visit_pos :
'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) ed -> unit
; .. >
method visit_pos : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) t -> unit
method visit_pos : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) ed -> unit
end

6
compiler/catala_utils/uid.ml
View File

@ -69,12 +69,12 @@ module Make (X : Info) () : Id with type info = X.info = struct
end
module MarkedString = struct
type info = string Marked.pos
type info = string Mark.pos
let to_string (s, _) = s
let format fmt i = Format.pp_print_string fmt (to_string i)
let equal i1 i2 = String.equal (Marked.unmark i1) (Marked.unmark i2)
let compare i1 i2 = String.compare (Marked.unmark i1) (Marked.unmark i2)
let equal = Mark.equal String.equal
let compare = Mark.compare String.compare
end
module Gen () = Make (MarkedString) ()

2
compiler/catala_utils/uid.mli
View File

@ -30,7 +30,7 @@ module type Info = sig
(** Comparison disregards position *)
end
module MarkedString : Info with type info = string Marked.pos
module MarkedString : Info with type info = string Mark.pos
(** The only kind of information carried in Catala identifiers is the original
string of the identifier annotated with the position where it is declared or
used. *)

203
compiler/dcalc/from_scopelang.ml
View File

@ -25,7 +25,7 @@ type scope_var_ctx = {
type scope_input_var_ctx = {
scope_input_name : StructField.t;
scope_input_io : Desugared.Ast.io_input Marked.pos;
scope_input_io : Desugared.Ast.io_input Mark.pos;
scope_input_typ : naked_typ;
}
@ -61,16 +61,16 @@ type 'm ctx = {
date_rounding : date_rounding;
}
let mark_tany m pos = Expr.with_ty m (Marked.mark pos TAny) ~pos
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) :
(Pos.t -> m mark) * ((_, Pos.t) Marked.t -> m mark) =
(Pos.t -> m mark) * ((_, Pos.t) Mark.ed -> m mark) =
let pos_mark pos =
Expr.map_mark (fun _ -> pos) (fun _ -> TAny, pos) (Marked.get_mark e)
Expr.map_mark (fun _ -> pos) (fun _ -> TAny, pos) (Mark.get e)
in
let pos_mark_as e = pos_mark (Marked.get_mark e) in
let pos_mark_as e = pos_mark (Mark.get e) in
pos_mark, pos_mark_as
let merge_defaults
@ -81,14 +81,14 @@ let merge_defaults
is straightfoward in the general case and a little subtler when the
variable being defined is a function. *)
if is_func then
let m_callee = Marked.get_mark callee in
let m_callee = Mark.get callee in
let unboxed_callee = Expr.unbox callee in
match Marked.unmark unboxed_callee with
match Mark.remove unboxed_callee with
| EAbs { binder; tys } ->
let vars, body = Bindlib.unmbind binder in
let m_body = Marked.get_mark body in
let m_body = Mark.get body in
let caller =
let m = Marked.get_mark caller in
let m = Mark.get caller in
let pos = Expr.mark_pos m in
Expr.make_app caller
(List.map2
@ -103,7 +103,7 @@ let merge_defaults
let ltrue =
Expr.elit (LBool true)
(Expr.with_ty m_callee
(Marked.mark (Expr.mark_pos m_callee) (TLit TBool)))
(Mark.add (Expr.mark_pos m_callee) (TLit TBool)))
in
let d = Expr.edefault [caller] ltrue (Expr.rebox body) m_body in
Expr.make_abs vars
@ -114,17 +114,17 @@ let merge_defaults
beginning of a default with a function type *)
else
let caller =
let m = Marked.get_mark caller in
let m = Mark.get caller in
let pos = Expr.mark_pos m in
Expr.make_app caller
[Expr.elit LUnit (Expr.with_ty m (Marked.mark pos (TLit TUnit)))]
[Expr.elit LUnit (Expr.with_ty m (Mark.add pos (TLit TUnit)))]
pos
in
let body =
let m = Marked.get_mark callee in
let m = Mark.get callee in
let ltrue =
Expr.elit (LBool true)
(Expr.with_ty m (Marked.mark (Expr.mark_pos m) (TLit TBool)))
(Expr.with_ty m (Mark.add (Expr.mark_pos m) (TLit TBool)))
in
Expr.eerroronempty (Expr.edefault [caller] ltrue callee m) m
in
@ -134,7 +134,7 @@ let tag_with_log_entry
(e : 'm Ast.expr boxed)
(l : log_entry)
(markings : Uid.MarkedString.info list) : 'm Ast.expr boxed =
let m = mark_tany (Marked.get_mark e) (Expr.pos e) in
let m = mark_tany (Mark.get e) (Expr.pos e) in
if !Cli.trace_flag then
Expr.eapp (Expr.eop (Log (l, markings)) [TAny, Expr.pos e] m) [e] m
@ -189,10 +189,10 @@ let thunk_scope_arg ~is_func io_in e =
that we can put them in default terms at the initialisation of the function
body, allowing an empty error to recover the default value. *)
let silent_var = Var.make "_" in
let pos = Marked.get_mark io_in in
match Marked.unmark io_in with
let pos = Mark.get io_in in
match Mark.remove io_in with
| Desugared.Ast.NoInput -> invalid_arg "thunk_scope_arg"
| Desugared.Ast.OnlyInput -> Expr.eerroronempty e (Marked.get_mark e)
| Desugared.Ast.OnlyInput -> Expr.eerroronempty e (Mark.get e)
| Desugared.Ast.Reentrant ->
(* we don't need to thunk expressions that are already functions *)
if is_func then e
@ -200,8 +200,8 @@ let thunk_scope_arg ~is_func io_in e =
let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
'm Ast.expr boxed =
let m = Marked.get_mark e in
match Marked.unmark e with
let m = Mark.get e in
match Mark.remove e with
| EVar v -> Expr.evar (Var.Map.find v ctx.local_vars) m
| ELit
((LBool _ | LInt _ | LRat _ | LMoney _ | LUnit | LDate _ | LDuration _) as
@ -276,8 +276,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
[
None, pos;
( Some "Declaration of the missing input variable",
Marked.get_mark
(StructField.get_info var_ctx.scope_input_name) );
Mark.get (StructField.get_info var_ctx.scope_input_name) );
]
"Definition of input variable '%a' missing in this scope call"
ScopeVar.format_t var_name
@ -286,7 +285,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
[
None, pos;
( Some "Declaration of scope '%a'",
Marked.get_mark (ScopeName.get_info scope) );
Mark.get (ScopeName.get_info scope) );
]
"Unknown input variable '%a' in scope call of '%a'"
ScopeVar.format_t var_name ScopeName.format_t scope)
@ -304,22 +303,22 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
tag_with_log_entry
(Expr.evar sc_sig.scope_sig_scope_var (mark_tany m pos))
BeginCall
[ScopeName.get_info scope; Marked.mark (Expr.pos e) "direct"]
[ScopeName.get_info scope; Mark.add (Expr.pos e) "direct"]
in
let single_arg =
tag_with_log_entry arg_struct
(VarDef (TStruct sc_sig.scope_sig_input_struct))
[
ScopeName.get_info scope;
Marked.mark (Expr.pos e) "direct";
Marked.mark (Expr.pos e) "input";
Mark.add (Expr.pos e) "direct";
Mark.add (Expr.pos e) "input";
]
in
let direct_output_info =
[
ScopeName.get_info scope;
Marked.mark (Expr.pos e) "direct";
Marked.mark (Expr.pos e) "output";
Mark.add (Expr.pos e) "direct";
Mark.add (Expr.pos e) "output";
]
in
(* calling_expr = scope_function scope_input_struct *)
@ -355,7 +354,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
(TStruct sc_sig.scope_sig_output_struct, Expr.pos e)))
field sc_sig.scope_sig_output_struct (Expr.with_ty m typ)
in
match Marked.unmark typ with
match Mark.remove typ with
| TArrow (ts_in, t_out) ->
(* Here the output scope struct field is a function so we
eta-expand it and insert logging instructions. Invariant:
@ -378,15 +377,15 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
~f:(fun i (param_var, t_in) ->
tag_with_log_entry
(Expr.make_var param_var (Expr.with_ty m t_in))
(VarDef (Marked.unmark t_in))
(VarDef (Mark.remove t_in))
(f_markings
@ [
Marked.mark (Expr.pos e)
Mark.add (Expr.pos e)
("input" ^ string_of_int i);
])))
(Expr.with_ty m t_out))
(VarDef (Marked.unmark t_out))
(f_markings @ [Marked.mark (Expr.pos e) "output"]))
(VarDef (Mark.remove t_out))
(f_markings @ [Mark.add (Expr.pos e) "output"]))
EndCall f_markings)
ts_in (Expr.pos e)
| _ -> original_field_expr)
@ -403,7 +402,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
Expr.eifthenelse
(tag_with_log_entry
(Expr.box
(Marked.mark
(Mark.add
(Expr.with_ty m (TLit TBool, Expr.pos e))
(ELit (LBool true))))
PosRecordIfTrueBool direct_output_info)
@ -426,7 +425,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
(VarDef (TStruct sc_sig.scope_sig_output_struct))
direct_output_info)
EndCall
[ScopeName.get_info scope; Marked.mark (Expr.pos e) "direct"])
[ScopeName.get_info scope; Mark.add (Expr.pos e) "direct"])
(Expr.pos e))
(Expr.pos e)
| EApp { f; args } ->
@ -434,7 +433,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
user-defined functions belonging to scopes *)
let e1_func = translate_expr ctx f in
let markings =
match ctx.scope_name, Marked.unmark f with
match ctx.scope_name, Mark.remove f with
| Some sname, ELocation loc -> (
match loc with
| ScopelangScopeVar (v, _) ->
@ -456,26 +455,23 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
-- for more information see
https://github.com/CatalaLang/catala/pull/280#discussion_r898851693. *)
let retrieve_in_and_out_typ_or_any var vars =
let _, typ, _ = ScopeVar.Map.find (Marked.unmark var) vars in
let _, typ, _ = ScopeVar.Map.find (Mark.remove var) vars in
match typ with
| TArrow (marked_input_typ, marked_output_typ) ->
( List.map Marked.unmark marked_input_typ,
Marked.unmark marked_output_typ )
List.map Mark.remove marked_input_typ, Mark.remove marked_output_typ
| _ -> ListLabels.map new_args ~f:(fun _ -> TAny), TAny
in
match Marked.unmark f with
match Mark.remove f with
| ELocation (ScopelangScopeVar var) ->
retrieve_in_and_out_typ_or_any var ctx.scope_vars
| ELocation (SubScopeVar (_, sname, var)) ->
ctx.subscope_vars
|> SubScopeName.Map.find (Marked.unmark sname)
|> SubScopeName.Map.find (Mark.remove sname)
|> retrieve_in_and_out_typ_or_any var
| ELocation (ToplevelVar tvar) -> (
let _, typ =
TopdefName.Map.find (Marked.unmark tvar) ctx.toplevel_vars
in
let _, typ = TopdefName.Map.find (Mark.remove tvar) ctx.toplevel_vars in
match typ with
| TArrow (tin, (tout, _)) -> List.map Marked.unmark tin, tout
| TArrow (tin, (tout, _)) -> List.map Mark.remove tin, tout
| _ ->
Errors.raise_spanned_error (Expr.pos e)
"Application of non-function toplevel variable")
@ -484,14 +480,14 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
(* Cli.debug_format "new_args %d, input_typs: %d, input_typs %a"
(List.length new_args) (List.length input_typs) (Format.pp_print_list
Print.typ_debug) (List.map (Marked.mark Pos.no_pos) input_typs); *)
Print.typ_debug) (List.map (Mark.add Pos.no_pos) input_typs); *)
let new_args =
ListLabels.mapi (List.combine new_args input_typs)
~f:(fun i (new_arg, input_typ) ->
match markings with
| _ :: _ as m ->
tag_with_log_entry new_arg (VarDef input_typ)
(m @ [Marked.mark (Expr.pos e) ("input" ^ string_of_int i)])
(m @ [Mark.add (Expr.pos e) ("input" ^ string_of_int i)])
| _ -> new_arg)
in
@ -502,7 +498,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
| m ->
tag_with_log_entry
(tag_with_log_entry new_e (VarDef output_typ)
(m @ [Marked.mark (Expr.pos e) "output"]))
(m @ [Mark.add (Expr.pos e) "output"]))
EndCall m
in
new_e
@ -529,13 +525,13 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
(List.map (translate_expr ctx) excepts)
(translate_expr ctx just) (translate_expr ctx cons) m
| ELocation (ScopelangScopeVar a) ->
let v, _, _ = ScopeVar.Map.find (Marked.unmark a) ctx.scope_vars in
let v, _, _ = ScopeVar.Map.find (Mark.remove a) ctx.scope_vars in
Expr.evar v m
| ELocation (SubScopeVar (_, s, a)) -> (
try
let v, _, _ =
ScopeVar.Map.find (Marked.unmark a)
(SubScopeName.Map.find (Marked.unmark s) ctx.subscope_vars)
ScopeVar.Map.find (Mark.remove a)
(SubScopeName.Map.find (Mark.remove s) ctx.subscope_vars)
in
Expr.evar v m
with Not_found ->
@ -543,16 +539,16 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
[
Some "Incriminated variable usage:", Expr.pos e;
( Some "Incriminated subscope variable declaration:",
Marked.get_mark (ScopeVar.get_info (Marked.unmark a)) );
Mark.get (ScopeVar.get_info (Mark.remove a)) );
( Some "Incriminated subscope declaration:",
Marked.get_mark (SubScopeName.get_info (Marked.unmark s)) );
Mark.get (SubScopeName.get_info (Mark.remove s)) );
]
"The variable %a.%a cannot be used here, as it is not part of subscope \
%a's results. Maybe you forgot to qualify it as an output?"
SubScopeName.format_t (Marked.unmark s) ScopeVar.format_t
(Marked.unmark a) SubScopeName.format_t (Marked.unmark s))
SubScopeName.format_t (Mark.remove s) ScopeVar.format_t (Mark.remove a)
SubScopeName.format_t (Mark.remove s))
| ELocation (ToplevelVar v) ->
let v, _ = TopdefName.Map.find (Marked.unmark v) ctx.toplevel_vars in
let v, _ = TopdefName.Map.find (Mark.remove v) ctx.toplevel_vars in
Expr.evar v m
| EIfThenElse { cond; etrue; efalse } ->
Expr.eifthenelse (translate_expr ctx cond) (translate_expr ctx etrue)
@ -580,15 +576,13 @@ let translate_rule
match rule with
| Definition ((ScopelangScopeVar a, var_def_pos), tau, a_io, e) ->
let pos_mark, pos_mark_as = pos_mark_mk e in
let a_name = ScopeVar.get_info (Marked.unmark a) in
let a_var = Var.make (Marked.unmark a_name) in
let a_name = ScopeVar.get_info (Mark.remove a) in
let a_var = Var.make (Mark.remove a_name) in
let new_e = translate_expr ctx e in
let a_expr = Expr.make_var a_var (pos_mark var_def_pos) in
let is_func =
match Marked.unmark tau with TArrow _ -> true | _ -> false
in
let is_func = match Mark.remove tau with TArrow _ -> true | _ -> false in
let merged_expr =
match Marked.unmark a_io.io_input with
match Mark.remove a_io.io_input with
| OnlyInput -> failwith "should not happen"
(* scopelang should not contain any definitions of input only variables *)
| Reentrant -> merge_defaults ~is_func a_expr new_e
@ -597,7 +591,7 @@ let translate_rule
in
let merged_expr =
tag_with_log_entry merged_expr
(VarDef (Marked.unmark tau))
(VarDef (Mark.remove tau))
[sigma_name, pos_sigma; a_name]
in
( (fun next ->
@ -609,15 +603,15 @@ let translate_rule
scope_let_typ = tau;
scope_let_expr = merged_expr;
scope_let_kind = ScopeVarDefinition;
scope_let_pos = Marked.get_mark a;
scope_let_pos = Mark.get a;
})
(Bindlib.bind_var a_var next)
(Expr.Box.lift merged_expr)),
{
ctx with
scope_vars =
ScopeVar.Map.add (Marked.unmark a)
(a_var, Marked.unmark tau, a_io)
ScopeVar.Map.add (Mark.remove a)
(a_var, Mark.remove tau, a_io)
ctx.scope_vars;
} )
| Definition
@ -626,20 +620,18 @@ let translate_rule
a_io,
e ) ->
let a_name =
Marked.map_under_mark
Mark.map
(fun str ->
str ^ "." ^ Marked.unmark (ScopeVar.get_info (Marked.unmark subs_var)))
(SubScopeName.get_info (Marked.unmark subs_index))
str ^ "." ^ Mark.remove (ScopeVar.get_info (Mark.remove subs_var)))
(SubScopeName.get_info (Mark.remove subs_index))
in
let a_var = Var.make (Marked.unmark a_name) in
let a_var = Var.make (Mark.remove a_name) in
let new_e =
tag_with_log_entry (translate_expr ctx e)
(VarDef (Marked.unmark tau))
(VarDef (Mark.remove tau))
[sigma_name, pos_sigma; a_name]
in
let is_func =
match Marked.unmark tau with TArrow _ -> true | _ -> false
in
let is_func = match Mark.remove tau with TArrow _ -> true | _ -> false in
let thunked_or_nonempty_new_e =
thunk_scope_arg ~is_func a_io.Desugared.Ast.io_input new_e
in
@ -649,9 +641,9 @@ let translate_rule
ScopeLet
{
scope_let_next = next;
scope_let_pos = Marked.get_mark a_name;
scope_let_pos = Mark.get a_name;
scope_let_typ =
(match Marked.unmark a_io.io_input with
(match Mark.remove a_io.io_input with
| NoInput -> failwith "should not happen"
| OnlyInput -> tau
| Reentrant ->
@ -665,18 +657,18 @@ let translate_rule
{
ctx with
subscope_vars =
SubScopeName.Map.update (Marked.unmark subs_index)
SubScopeName.Map.update (Mark.remove subs_index)
(fun map ->
match map with
| Some map ->
Some
(ScopeVar.Map.add (Marked.unmark subs_var)
(a_var, Marked.unmark tau, a_io)
(ScopeVar.Map.add (Mark.remove subs_var)
(a_var, Mark.remove tau, a_io)
map)
| None ->
Some
(ScopeVar.Map.singleton (Marked.unmark subs_var)
(a_var, Marked.unmark tau, a_io)))
(ScopeVar.Map.singleton (Mark.remove subs_var)
(a_var, Mark.remove tau, a_io)))
ctx.subscope_vars;
} )
| Definition ((ToplevelVar _, _), _, _, _) ->
@ -690,7 +682,7 @@ let translate_rule
let all_subscope_input_vars =
List.filter
(fun var_ctx ->
match Marked.unmark var_ctx.scope_var_io.Desugared.Ast.io_input with
match Mark.remove var_ctx.scope_var_io.Desugared.Ast.io_input with
| NoInput -> false
| _ -> true)
all_subscope_vars
@ -698,7 +690,7 @@ let translate_rule
let all_subscope_output_vars =
List.filter
(fun var_ctx ->
Marked.unmark var_ctx.scope_var_io.Desugared.Ast.io_output)
Mark.remove var_ctx.scope_var_io.Desugared.Ast.io_output)
all_subscope_vars
in
let scope_dcalc_var = subscope_sig.scope_sig_scope_var in
@ -711,7 +703,7 @@ let translate_rule
let subscope_var_not_yet_defined subvar =
not (ScopeVar.Map.mem subvar subscope_vars_defined)
in
let pos_call = Marked.get_mark (SubScopeName.get_info subindex) in
let pos_call = Mark.get (SubScopeName.get_info subindex) in
let subscope_args =
List.fold_left
(fun acc (subvar : scope_var_ctx) ->
@ -745,9 +737,9 @@ let translate_rule
(fun (subvar : scope_var_ctx) ->
let sub_dcalc_var =
Var.make
(Marked.unmark (SubScopeName.get_info subindex)
(Mark.remove (SubScopeName.get_info subindex)
^ "."
^ Marked.unmark (ScopeVar.get_info subvar.scope_var_name))
^ Mark.remove (ScopeVar.get_info subvar.scope_var_name))
in
subvar, sub_dcalc_var)
all_subscope_output_vars
@ -841,9 +833,9 @@ let translate_rule
scope_let_expr =
(* To ensure that we throw an error if the value is not
defined, we add an check "ErrorOnEmpty" here. *)
Marked.mark
(Expr.map_ty (fun _ -> scope_let_typ) (Marked.get_mark e))
(EAssert (Marked.same_mark_as (EErrorOnEmpty new_e) e));
Mark.add
(Expr.map_ty (fun _ -> scope_let_typ) (Mark.get e))
(EAssert (Mark.copy e (EErrorOnEmpty new_e)));
scope_let_kind = Assertion;
})
(Bindlib.bind_var (Var.make "_") next)
@ -871,7 +863,7 @@ let translate_rules
Expr.estruct scope_sig.scope_sig_output_struct
(ScopeVar.Map.fold
(fun var (dcalc_var, _, io) acc ->
if Marked.unmark io.Desugared.Ast.io_output then
if Mark.remove io.Desugared.Ast.io_output then
let field = ScopeVar.Map.find var scope_sig.scope_sig_out_fields in
StructField.Map.add field
(Expr.make_var dcalc_var (mark_tany mark pos_sigma))
@ -902,10 +894,10 @@ let translate_scope_decl
scope variables *)
List.fold_left
(fun ctx scope_var ->
match Marked.unmark scope_var.scope_var_io.io_input with
match Mark.remove scope_var.scope_var_io.io_input with
| OnlyInput ->
let scope_var_name = ScopeVar.get_info scope_var.scope_var_name in
let scope_var_dcalc = Var.make (Marked.unmark scope_var_name) in
let scope_var_dcalc = Var.make (Mark.remove scope_var_name) in
{
ctx with
scope_vars =
@ -932,7 +924,7 @@ let translate_scope_decl
let scope_input_var = scope_sig.scope_sig_input_var in
let scope_input_struct_name = scope_sig.scope_sig_input_struct in
let scope_return_struct_name = scope_sig.scope_sig_output_struct in
let pos_sigma = Marked.get_mark sigma_info in
let pos_sigma = Mark.get sigma_info in
let rules_with_return_expr, ctx =
translate_rules ctx sigma.scope_decl_rules sigma_info sigma.scope_mark
scope_sig
@ -950,13 +942,13 @@ let translate_scope_decl
let scope_input_variables =
List.filter
(fun (var_ctx, _) ->
match Marked.unmark var_ctx.scope_var_io.io_input with
match Mark.remove var_ctx.scope_var_io.io_input with
| NoInput -> false
| _ -> true)
scope_variables
in
let input_var_typ (var_ctx : scope_var_ctx) =
match Marked.unmark var_ctx.scope_var_io.io_input with
match Mark.remove var_ctx.scope_var_io.io_input with
| OnlyInput -> var_ctx.scope_var_typ, pos_sigma
| Reentrant -> (
match var_ctx.scope_var_typ with
@ -1029,33 +1021,30 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
(fun scope_name scope ->
let scope_dvar =
Var.make
(Marked.unmark
(Mark.remove
(ScopeName.get_info scope.Scopelang.Ast.scope_decl_name))
in
let scope_return = ScopeName.Map.find scope_name decl_ctx.ctx_scopes in
let scope_input_var =
Var.make (Marked.unmark (ScopeName.get_info scope_name) ^ "_in")
Var.make (Mark.remove (ScopeName.get_info scope_name) ^ "_in")
in
let scope_input_struct_name =
StructName.fresh
(Marked.map_under_mark
(fun s -> s ^ "_in")
(ScopeName.get_info scope_name))
(Mark.map (fun s -> s ^ "_in") (ScopeName.get_info scope_name))
in
let scope_sig_in_fields =
ScopeVar.Map.filter_map
(fun dvar (typ, vis) ->
match Marked.unmark vis.Desugared.Ast.io_input with
match Mark.remove vis.Desugared.Ast.io_input with
| NoInput -> None
| OnlyInput | Reentrant ->
let info = ScopeVar.get_info dvar in
let s = Marked.unmark info ^ "_in" in
let s = Mark.remove info ^ "_in" in
Some
{
scope_input_name =
StructField.fresh (s, Marked.get_mark info);
scope_input_name = StructField.fresh (s, Mark.get info);
scope_input_io = vis.Desugared.Ast.io_input;
scope_input_typ = Marked.unmark typ;
scope_input_typ = Mark.remove typ;
})
scope.scope_sig
in
@ -1065,7 +1054,7 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
(fun (scope_var, (tau, vis)) ->
{
scope_var_name = scope_var;
scope_var_typ = Marked.unmark tau;
scope_var_typ = Mark.remove tau;
scope_var_io = vis;
})
(ScopeVar.Map.bindings scope.scope_sig);
@ -1082,7 +1071,7 @@ let translate_program (prgm : 'm Scopelang.Ast.program) : 'm Ast.program =
let toplevel_vars =
TopdefName.Map.mapi
(fun name (_, ty) ->
Var.make (Marked.unmark (TopdefName.get_info name)), Marked.unmark ty)
Var.make (Mark.remove (TopdefName.get_info name)), Mark.remove ty)
prgm.Scopelang.Ast.program_topdefs
in
{

18
compiler/dcalc/invariants.ml
View File

@ -62,9 +62,9 @@ let check_invariant (inv : string * invariant_expr) (p : typed program) : bool =
let invariant_default_no_arrow () : string * invariant_expr =
( __FUNCTION__,
fun e ->
match Marked.unmark e with
match Mark.remove e with
| EDefault _ -> begin
match Marked.unmark (Expr.ty e) with TArrow _ -> Fail | _ -> Pass
match Mark.remove (Expr.ty e) with TArrow _ -> Fail | _ -> Pass
end
| _ -> Ignore )
@ -72,11 +72,11 @@ let invariant_default_no_arrow () : string * invariant_expr =
let invariant_no_partial_evaluation () : string * invariant_expr =
( __FUNCTION__,
fun e ->
match Marked.unmark e with
match Mark.remove e with
| EApp { f = EOp { op = Op.Log _; _ }, _; _ } ->
(* logs are differents. *) Pass
| EApp _ -> begin
match Marked.unmark (Expr.ty e) with TArrow _ -> Fail | _ -> Pass
match Mark.remove (Expr.ty e) with TArrow _ -> Fail | _ -> Pass
end
| _ -> Ignore )
@ -84,9 +84,9 @@ let invariant_no_partial_evaluation () : string * invariant_expr =
let invariant_no_return_a_function () : string * invariant_expr =
( __FUNCTION__,
fun e ->
match Marked.unmark e with
match Mark.remove e with
| EAbs _ -> begin
match Marked.unmark (Expr.ty e) with
match Mark.remove (Expr.ty e) with
| TArrow (_, (TArrow _, _)) -> Fail
| _ -> Pass
end
@ -95,7 +95,7 @@ let invariant_no_return_a_function () : string * invariant_expr =
let invariant_app_inversion () : string * invariant_expr =
( __FUNCTION__,
fun e ->
match Marked.unmark e with
match Mark.remove e with
| EApp { f = EOp _, _; _ } -> Pass
| EApp { f = EAbs { binder; _ }, _; args } ->
if Bindlib.mbinder_arity binder = 1 && List.length args = 1 then Pass
@ -111,12 +111,12 @@ let invariant_app_inversion () : string * invariant_expr =
let invariant_match_inversion () : string * invariant_expr =
( __FUNCTION__,
fun e ->
match Marked.unmark e with
match Mark.remove e with
| EMatch { cases; _ } ->
if
EnumConstructor.Map.for_all
(fun _ case ->
match Marked.unmark case with
match Mark.remove case with
| EAbs { binder; _ } -> Bindlib.mbinder_arity binder = 1
| _ -> false)
cases

44
compiler/desugared/ast.ml
View File

@ -46,8 +46,8 @@ module ScopeDef = struct
let get_position x =
match x with
| Var (x, None) -> Marked.get_mark (ScopeVar.get_info x)
| Var (_, Some sx) -> Marked.get_mark (StateName.get_info sx)
| Var (x, None) -> Mark.get (ScopeVar.get_info x)
| Var (_, Some sx) -> Mark.get (StateName.get_info sx)
| SubScopeVar (_, _, pos) -> pos
let format_t fmt x =
@ -77,9 +77,8 @@ module AssertionName = Uid.Gen ()
type location = desugared glocation
module LocationSet : Set.S with type elt = location Marked.pos =
Set.Make (struct
type t = location Marked.pos
module LocationSet : Set.S with type elt = location Mark.pos = Set.Make (struct
type t = location Mark.pos
let compare = Expr.compare_location
end)
@ -93,20 +92,20 @@ module ExprMap = Map.Make (struct
end)
type io_input = NoInput | OnlyInput | Reentrant
type io = { io_output : bool Marked.pos; io_input : io_input Marked.pos }
type io = { io_output : bool Mark.pos; io_input : io_input Mark.pos }
type exception_situation =
| BaseCase
| ExceptionToLabel of LabelName.t Marked.pos
| ExceptionToRule of RuleName.t Marked.pos
| ExceptionToLabel of LabelName.t Mark.pos
| ExceptionToRule of RuleName.t Mark.pos
type label_situation = ExplicitlyLabeled of LabelName.t Marked.pos | Unlabeled
type label_situation = ExplicitlyLabeled of LabelName.t Mark.pos | Unlabeled
type rule = {
rule_id : RuleName.t;
rule_just : expr boxed;
rule_cons : expr boxed;
rule_parameter : (expr Var.t Marked.pos * typ) list Marked.pos option;
rule_parameter : (expr Var.t Mark.pos * typ) list Mark.pos option;
rule_exception : exception_situation;
rule_label : label_situation;
}
@ -167,14 +166,13 @@ end
let empty_rule
(pos : Pos.t)
(parameters : (Uid.MarkedString.info * typ) list Marked.pos option) : rule =
(parameters : (Uid.MarkedString.info * typ) list Mark.pos option) : rule =
{
rule_just = Expr.box (ELit (LBool false), Untyped { pos });
rule_cons = Expr.box (EEmptyError, Untyped { pos });
rule_parameter =
Option.map
(Marked.map_under_mark
(List.map (fun (lbl, typ) -> Marked.map_under_mark Var.make lbl, typ)))
(Mark.map (List.map (fun (lbl, typ) -> Mark.map Var.make lbl, typ)))
parameters;
rule_exception = BaseCase;
rule_id = RuleName.fresh ("empty", pos);
@ -183,14 +181,13 @@ let empty_rule
let always_false_rule
(pos : Pos.t)
(parameters : (Uid.MarkedString.info * typ) list Marked.pos option) : rule =
(parameters : (Uid.MarkedString.info * typ) list Mark.pos option) : rule =
{
rule_just = Expr.box (ELit (LBool true), Untyped { pos });
rule_cons = Expr.box (ELit (LBool false), Untyped { pos });
rule_parameter =
Option.map
(Marked.map_under_mark
(List.map (fun (lbl, typ) -> Marked.map_under_mark Var.make lbl, typ)))
(Mark.map (List.map (fun (lbl, typ) -> Mark.map Var.make lbl, typ)))
parameters;
rule_exception = BaseCase;
rule_id = RuleName.fresh ("always_false", pos);
@ -203,13 +200,13 @@ type reference_typ = Decree | Law
type catala_option = DateRounding of variation_typ
type meta_assertion =
| FixedBy of reference_typ Marked.pos
| VariesWith of unit * variation_typ Marked.pos option
| FixedBy of reference_typ Mark.pos
| VariesWith of unit * variation_typ Mark.pos option
type scope_def = {
scope_def_rules : rule RuleName.Map.t;
scope_def_typ : typ;
scope_def_parameters : (Uid.MarkedString.info * typ) list Marked.pos option;
scope_def_parameters : (Uid.MarkedString.info * typ) list Mark.pos option;
scope_def_is_condition : bool;
scope_def_io : io;
}
@ -222,7 +219,7 @@ type scope = {
scope_uid : ScopeName.t;
scope_defs : scope_def ScopeDef.Map.t;
scope_assertions : assertion AssertionName.Map.t;
scope_options : catala_option Marked.pos list;
scope_options : catala_option Mark.pos list;
scope_meta_assertions : meta_assertion list;
}
@ -250,14 +247,11 @@ let free_variables (def : rule RuleName.Map.t) : Pos.t ScopeDef.Map.t =
(fun (loc, loc_pos) acc ->
let usage =
match loc with
| DesugaredScopeVar (v, st) ->
Some (ScopeDef.Var (Marked.unmark v, st))
| DesugaredScopeVar (v, st) -> Some (ScopeDef.Var (Mark.remove v, st))
| SubScopeVar (_, sub_index, sub_var) ->
Some
(ScopeDef.SubScopeVar
( Marked.unmark sub_index,
Marked.unmark sub_var,
Marked.get_mark sub_index ))
(Mark.remove sub_index, Mark.remove sub_var, Mark.get sub_index))
| ToplevelVar _ -> None
in
match usage with

26
compiler/desugared/ast.mli
View File

@ -46,23 +46,23 @@ type expr = (desugared, untyped mark) gexpr
type location = desugared glocation
module LocationSet : Set.S with type elt = location Marked.pos
module LocationSet : Set.S with type elt = location Mark.pos
module ExprMap : Map.S with type key = expr
(** {2 Rules and scopes}*)
type exception_situation =
| BaseCase
| ExceptionToLabel of LabelName.t Marked.pos
| ExceptionToRule of RuleName.t Marked.pos
| ExceptionToLabel of LabelName.t Mark.pos
| ExceptionToRule of RuleName.t Mark.pos
type label_situation = ExplicitlyLabeled of LabelName.t Marked.pos | Unlabeled
type label_situation = ExplicitlyLabeled of LabelName.t Mark.pos | Unlabeled
type rule = {
rule_id : RuleName.t;
rule_just : expr boxed;
rule_cons : expr boxed;
rule_parameter : (expr Var.t Marked.pos * typ) list Marked.pos option;
rule_parameter : (expr Var.t Mark.pos * typ) list Mark.pos option;
rule_exception : exception_situation;
rule_label : label_situation;
}
@ -70,10 +70,10 @@ type rule = {
module Rule : Set.OrderedType with type t = rule
val empty_rule :
Pos.t -> (Uid.MarkedString.info * typ) list Marked.pos option -> rule
Pos.t -> (Uid.MarkedString.info * typ) list Mark.pos option -> rule
val always_false_rule :
Pos.t -> (Uid.MarkedString.info * typ) list Marked.pos option -> rule
Pos.t -> (Uid.MarkedString.info * typ) list Mark.pos option -> rule
type assertion = expr boxed
type variation_typ = Increasing | Decreasing
@ -81,8 +81,8 @@ type reference_typ = Decree | Law
type catala_option = DateRounding of variation_typ
type meta_assertion =
| FixedBy of reference_typ Marked.pos
| VariesWith of unit * variation_typ Marked.pos option
| FixedBy of reference_typ Mark.pos
| VariesWith of unit * variation_typ Mark.pos option
(** This type characterizes the three levels of visibility for a given scope
variable with regards to the scope's input and possible redefinitions inside
@ -99,9 +99,9 @@ type io_input =
caller as they appear in the input. *)
type io = {
io_output : bool Marked.pos;
io_output : bool Mark.pos;
(** [true] is present in the output of the scope. *)
io_input : io_input Marked.pos;
io_input : io_input Mark.pos;
}
(** Characterization of the input/output status of a scope variable. *)
@ -109,7 +109,7 @@ type scope_def = {
scope_def_rules : rule RuleName.Map.t;
scope_def_typ : typ;
scope_def_parameters :
(Uid.MarkedString.info * Shared_ast.typ) list Marked.pos option;
(Uid.MarkedString.info * Shared_ast.typ) list Mark.pos option;
scope_def_is_condition : bool;
scope_def_io : io;
}
@ -122,7 +122,7 @@ type scope = {
scope_uid : ScopeName.t;
scope_defs : scope_def ScopeDef.Map.t;
scope_assertions : assertion AssertionName.Map.t;
scope_options : catala_option Marked.pos list;
scope_options : catala_option Mark.pos list;
scope_meta_assertions : meta_assertion list;
}

13
compiler/desugared/dependency.ml
View File

@ -260,11 +260,10 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
Ast.LocationSet.fold
(fun used_var g ->
let edge_from =
match Marked.unmark used_var with
| DesugaredScopeVar (v, s) ->
Some (Vertex.Var (Marked.unmark v, s))
match Mark.remove used_var with
| DesugaredScopeVar (v, s) -> Some (Vertex.Var (Mark.remove v, s))
| SubScopeVar (_, subscope_name, _) ->
Some (Vertex.SubScope (Marked.unmark subscope_name))
Some (Vertex.SubScope (Mark.remove subscope_name))
| ToplevelVar _ -> None
(* we don't add this dependency because toplevel definitions are
outside the scope *)
@ -353,7 +352,7 @@ let build_exceptions_graph
| None ->
RuleName.Map.add rule_to
(LabelName.fresh
( "exception_to_" ^ Marked.unmark (RuleName.get_info rule_to),
( "exception_to_" ^ Mark.remove (RuleName.get_info rule_to),
Pos.no_pos ))
exception_to_rule_implicit_labels)
| _ -> exception_to_rule_implicit_labels)
@ -377,7 +376,7 @@ let build_exceptions_graph
| None ->
LabelName.Map.add label_to
(LabelName.fresh
( "exception_to_" ^ Marked.unmark (LabelName.get_info label_to),
( "exception_to_" ^ Mark.remove (LabelName.get_info label_to),
Pos.no_pos ))
exception_to_label_implicit_labels)
| _ -> exception_to_label_implicit_labels)
@ -537,7 +536,7 @@ let check_for_exception_cycle
(fun (vs : ExceptionVertex.t) ->
let v, _ = RuleName.Map.choose vs.rules in
let rule = RuleName.Map.find v def in
let pos = Marked.get_mark (RuleName.get_info rule.Ast.rule_id) in
let pos = Mark.get (RuleName.get_info rule.Ast.rule_id) in
None, pos)
scc
in

204
compiler/desugared/from_surface.ml
View File

@ -37,7 +37,7 @@ module Runtime = Runtime_ocaml.Runtime
let translate_binop : Surface.Ast.binop -> Pos.t -> Ast.expr boxed =
fun op pos ->
let op_expr op tys =
Expr.eop op (List.map (Marked.mark pos) tys) (Untyped { pos })
Expr.eop op (List.map (Mark.add pos) tys) (Untyped { pos })
in
match op with
| S.And -> op_expr And [TLit TBool; TLit TBool]
@ -105,7 +105,7 @@ let translate_binop : Surface.Ast.binop -> Pos.t -> Ast.expr boxed =
| S.Concat -> op_expr Concat [TArray (TAny, pos); TArray (TAny, pos)]
let translate_unop (op : Surface.Ast.unop) pos : Ast.expr boxed =
let op_expr op ty = Expr.eop op [Marked.mark pos ty] (Untyped { pos }) in
let op_expr op ty = Expr.eop op [Mark.add pos ty] (Untyped { pos }) in
match op with
| S.Not -> op_expr Not (TLit TBool)
| S.Minus k ->
@ -122,28 +122,26 @@ let translate_unop (op : Surface.Ast.unop) pos : Ast.expr boxed =
let disambiguate_constructor
(ctxt : Name_resolution.context)
(constructor : (S.path * S.uident Marked.pos) Marked.pos list)
(constructor : (S.path * S.uident Mark.pos) Mark.pos list)
(pos : Pos.t) : EnumName.t * EnumConstructor.t =
let path, constructor =
match constructor with
| [c] -> Marked.unmark c
| [c] -> Mark.remove c
| _ ->
Errors.raise_spanned_error pos
"The deep pattern matching syntactic sugar is not yet supported"
in
let possible_c_uids =
try IdentName.Map.find (Marked.unmark constructor) ctxt.constructor_idmap
try IdentName.Map.find (Mark.remove constructor) ctxt.constructor_idmap
with Not_found ->
Errors.raise_spanned_error
(Marked.get_mark constructor)
Errors.raise_spanned_error (Mark.get constructor)
"The name of this constructor has not been defined before, maybe it is \
a typo?"
in
match path with
| [] ->
if EnumName.Map.cardinal possible_c_uids > 1 then
Errors.raise_spanned_error
(Marked.get_mark constructor)
Errors.raise_spanned_error (Mark.get constructor)
"This constructor name is ambiguous, it can belong to %a. Disambiguate \
it by prefixing it with the enum name."
(Format.pp_print_list
@ -161,11 +159,10 @@ let disambiguate_constructor
e_uid, c_uid
with Not_found ->
Errors.raise_spanned_error pos "Enum %s does not contain case %s"
(Marked.unmark enum)
(Marked.unmark constructor)
(Mark.remove enum) (Mark.remove constructor)
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark enum)
"Enum %s has not been defined before" (Marked.unmark enum))
Errors.raise_spanned_error (Mark.get enum)
"Enum %s has not been defined before" (Mark.remove enum))
| _ -> Errors.raise_spanned_error pos "Qualified paths are not supported yet"
let int100 = Runtime.integer_of_int 100
@ -175,7 +172,7 @@ let rat100 = Runtime.decimal_of_integer int100
associativity. We actually want to reject anything that mixes operators
without parens, so that is handled here. *)
let rec check_formula (op, pos_op) e =
match Marked.unmark e with
match Mark.remove e with
| S.Binop ((((S.And | S.Or | S.Xor) as op1), pos_op1), e1, e2) ->
if op = S.Xor || op <> op1 then
(* Xor is mathematically associative, but without a useful semantics ([a
@ -196,7 +193,7 @@ let rec check_formula (op, pos_op) e =
[None] is assumed to mean a toplevel definition *)
let rec translate_expr
(scope : ScopeName.t option)
(inside_definition_of : Ast.ScopeDef.t Marked.pos option)
(inside_definition_of : Ast.ScopeDef.t Mark.pos option)
(ctxt : Name_resolution.context)
(expr : Surface.Ast.expression) : Ast.expr boxed =
let scope_vars =
@ -205,9 +202,9 @@ let rec translate_expr
| Some s -> (ScopeName.Map.find s ctxt.scopes).var_idmap
in
let rec_helper = translate_expr scope inside_definition_of ctxt in
let pos = Marked.get_mark expr in
let pos = Mark.get expr in
let emark = Untyped { pos } in
match Marked.unmark expr with
match Mark.remove expr with
| Paren e -> rec_helper e
| Binop
( (Surface.Ast.And, _pos_op),
@ -229,7 +226,7 @@ let rec translate_expr
[tau] pos
else
let ctxt, binding_var =
Name_resolution.add_def_local_var ctxt (Marked.unmark binding)
Name_resolution.add_def_local_var ctxt (Mark.remove binding)
in
let e2 = translate_expr scope inside_definition_of ctxt e2 in
Expr.make_abs [| binding_var |] e2 [tau] pos)
@ -241,7 +238,7 @@ let rec translate_expr
| Binop ((((S.And | S.Or | S.Xor), _) as op), e1, e2) ->
check_formula op e1;
check_formula op e2;
let op_term = translate_binop (Marked.unmark op) (Marked.get_mark op) in
let op_term = translate_binop (Mark.remove op) (Mark.get op) in
Expr.eapp op_term [rec_helper e1; rec_helper e2] emark
| IfThenElse (e_if, e_then, e_else) ->
Expr.eifthenelse (rec_helper e_if) (rec_helper e_then) (rec_helper e_else)
@ -358,7 +355,7 @@ let rec translate_expr
match IdentName.Map.find_opt x ctxt.topdefs with
| Some v ->
Expr.elocation
(ToplevelVar (v, Marked.get_mark (TopdefName.get_info v)))
(ToplevelVar (v, Mark.get (TopdefName.get_info v)))
emark
| None ->
Name_resolution.raise_unknown_identifier
@ -366,7 +363,7 @@ let rec translate_expr
| Ident (_path, _x) ->
Errors.raise_spanned_error pos "Qualified paths are not supported yet"
| Dotted (e, ((path, x), _ppos)) -> (
match path, Marked.unmark e with
match path, Mark.remove e with
| [], Ident ([], (y, _))
when Option.fold scope ~none:false ~some:(fun s ->
Name_resolution.is_subscope_uid s ctxt y) ->
@ -392,12 +389,12 @@ let rec translate_expr
| [c] -> (
try Some (Name_resolution.get_struct ctxt c)
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark c)
"Structure %s was not declared" (Marked.unmark c))
Errors.raise_spanned_error (Mark.get c)
"Structure %s was not declared" (Mark.remove c))
| _ ->
Errors.raise_spanned_error pos "Qualified paths are not supported yet"
in
Expr.edstructaccess e (Marked.unmark x) str emark)
Expr.edstructaccess e (Mark.remove x) str emark)
| FunCall (f, args) ->
Expr.eapp (rec_helper f) (List.map rec_helper args) emark
| ScopeCall ((([], sc_name), _), fields) ->
@ -411,26 +408,26 @@ let rec translate_expr
(fun acc (fld_id, e) ->
let var =
match
IdentName.Map.find_opt (Marked.unmark fld_id) scope_def.var_idmap
IdentName.Map.find_opt (Mark.remove fld_id) scope_def.var_idmap
with
| Some (ScopeVar v) -> v
| Some (SubScope _) | None ->
Errors.raise_multispanned_error
[
None, Marked.get_mark fld_id;
None, Mark.get fld_id;
( Some
(Format.asprintf "Scope %a declared here"
ScopeName.format_t called_scope),
Marked.get_mark (ScopeName.get_info called_scope) );
Mark.get (ScopeName.get_info called_scope) );
]
"Scope %a has no input variable %a" ScopeName.format_t
called_scope Print.lit_style (Marked.unmark fld_id)
called_scope Print.lit_style (Mark.remove fld_id)
in
ScopeVar.Map.update var
(function
| None -> Some (rec_helper e)
| Some _ ->
Errors.raise_spanned_error (Marked.get_mark fld_id)
Errors.raise_spanned_error (Mark.get fld_id)
"Duplicate definition of scope input variable '%a'"
ScopeVar.format_t var)
acc)
@ -440,8 +437,8 @@ let rec translate_expr
| ScopeCall (((_, _sc_name), _), _fields) ->
Errors.raise_spanned_error pos "Qualified paths are not supported yet"
| LetIn (x, e1, e2) ->
let ctxt, v = Name_resolution.add_def_local_var ctxt (Marked.unmark x) in
let tau = TAny, Marked.get_mark x in
let ctxt, v = Name_resolution.add_def_local_var ctxt (Mark.remove x) in
let tau = TAny, Mark.get x in
(* This type will be resolved in Scopelang.Desambiguation *)
let fn =
Expr.make_abs [| v |]
@ -451,10 +448,10 @@ let rec translate_expr
Expr.eapp fn [rec_helper e1] emark
| StructLit ((([], s_name), _), fields) ->
let s_uid =
match IdentName.Map.find_opt (Marked.unmark s_name) ctxt.typedefs with
match IdentName.Map.find_opt (Mark.remove s_name) ctxt.typedefs with
| Some (Name_resolution.TStruct s_uid) -> s_uid
| _ ->
Errors.raise_spanned_error (Marked.get_mark s_name)
Errors.raise_spanned_error (Mark.get s_name)
"This identifier should refer to a struct name"
in
@ -464,17 +461,17 @@ let rec translate_expr
let f_uid =
try
StructName.Map.find s_uid
(IdentName.Map.find (Marked.unmark f_name) ctxt.field_idmap)
(IdentName.Map.find (Mark.remove f_name) ctxt.field_idmap)
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark f_name)
Errors.raise_spanned_error (Mark.get f_name)
"This identifier should refer to a field of struct %s"
(Marked.unmark s_name)
(Mark.remove s_name)
in
(match StructField.Map.find_opt f_uid s_fields with
| None -> ()
| Some e_field ->
Errors.raise_multispanned_error
[None, Marked.get_mark f_e; None, Expr.pos e_field]
[None, Mark.get f_e; None, Expr.pos e_field]
"The field %a has been defined twice:" StructField.format_t f_uid);
let f_e = translate_expr scope inside_definition_of ctxt f_e in
StructField.Map.add f_uid f_e s_fields)
@ -542,10 +539,10 @@ let rec translate_expr
c_uid e_uid emark
with Not_found ->
Errors.raise_spanned_error pos "Enum %s does not contain case %s"
(Marked.unmark enum) constructor
(Mark.remove enum) constructor
with Not_found ->
Errors.raise_spanned_error (Marked.get_mark enum)
"Enum %s has not been defined before" (Marked.unmark enum))
Errors.raise_spanned_error (Mark.get enum)
"Enum %s has not been defined before" (Mark.remove enum))
| _ ->
Errors.raise_spanned_error pos "Qualified paths are not supported yet")
| MatchWith (e1, (cases, _cases_pos)) ->
@ -556,15 +553,15 @@ let rec translate_expr
in
Expr.ematch e1 e_uid cases_d emark
| TestMatchCase (e1, pattern) ->
(match snd (Marked.unmark pattern) with
(match snd (Mark.remove pattern) with
| None -> ()
| Some binding ->
Errors.format_spanned_warning (Marked.get_mark binding)
Errors.format_spanned_warning (Mark.get binding)
"This binding will be ignored (remove it to suppress warning)");
let enum_uid, c_uid =
disambiguate_constructor ctxt
(fst (Marked.unmark pattern))
(Marked.get_mark pattern)
(fst (Mark.remove pattern))
(Mark.get pattern)
in
let cases =
EnumConstructor.Map.mapi
@ -583,7 +580,7 @@ let rec translate_expr
let collection = rec_helper collection in
let param, predicate = f in
let ctxt, param =
Name_resolution.add_def_local_var ctxt (Marked.unmark param)
Name_resolution.add_def_local_var ctxt (Mark.remove param)
in
let f_pred =
Expr.make_abs [| param |]
@ -607,7 +604,7 @@ let rec translate_expr
let pos_dft = Expr.pos default in
let collection = rec_helper collection in
let ctxt, param =
Name_resolution.add_def_local_var ctxt (Marked.unmark param)
Name_resolution.add_def_local_var ctxt (Mark.remove param)
in
let cmp_op = if max then Op.Gt else Op.Lt in
let f_pred =
@ -652,13 +649,11 @@ let rec translate_expr
let init = Expr.elit (LBool init) emark in
let param0, predicate = predicate in
let ctxt, param =
Name_resolution.add_def_local_var ctxt (Marked.unmark param0)
Name_resolution.add_def_local_var ctxt (Mark.remove param0)
in
let f =
let acc_var = Var.make "acc" in
let acc =
Expr.make_var acc_var (Untyped { pos = Marked.get_mark param0 })
in
let acc = Expr.make_var acc_var (Untyped { pos = Mark.get param0 }) in
Expr.eabs
(Expr.bind [| acc_var; param |]
(Expr.eapp (translate_binop op pos)
@ -759,9 +754,9 @@ let rec translate_expr
and disambiguate_match_and_build_expression
(scope : ScopeName.t option)
(inside_definition_of : Ast.ScopeDef.t Marked.pos option)
(inside_definition_of : Ast.ScopeDef.t Mark.pos option)
(ctxt : Name_resolution.context)
(cases : Surface.Ast.match_case Marked.pos list) :
(cases : Surface.Ast.match_case Mark.pos list) :
Ast.expr boxed EnumConstructor.Map.t * EnumName.t =
let create_var = function
| None -> ctxt, Var.make "_"
@ -780,17 +775,17 @@ and disambiguate_match_and_build_expression
EnumConstructor.Map.find c_uid
(EnumName.Map.find e_uid ctxt.Name_resolution.enums);
]
(Marked.get_mark case_body)
(Mark.get case_body)
in
let bind_match_cases (cases_d, e_uid, curr_index) (case, case_pos) =
match case with
| Surface.Ast.MatchCase case ->
let constructor, binding =
Marked.unmark case.Surface.Ast.match_case_pattern
Mark.remove case.Surface.Ast.match_case_pattern
in
let e_uid', c_uid =
disambiguate_constructor ctxt constructor
(Marked.get_mark case.Surface.Ast.match_case_pattern)
(Mark.get case.Surface.Ast.match_case_pattern)
in
let e_uid =
match e_uid with
@ -799,7 +794,7 @@ and disambiguate_match_and_build_expression
if e_uid = e_uid' then e_uid
else
Errors.raise_spanned_error
(Marked.get_mark case.Surface.Ast.match_case_pattern)
(Mark.get case.Surface.Ast.match_case_pattern)
"This case matches a constructor of enumeration %a but previous \
case were matching constructors of enumeration %a"
EnumName.format_t e_uid EnumName.format_t e_uid'
@ -808,10 +803,10 @@ and disambiguate_match_and_build_expression
| None -> ()
| Some e_case ->
Errors.raise_multispanned_error
[None, Marked.get_mark case.match_case_expr; None, Expr.pos e_case]
[None, Mark.get case.match_case_expr; None, Expr.pos e_case]
"The constructor %a has been matched twice:" EnumConstructor.format_t
c_uid);
let ctxt, param_var = create_var (Option.map Marked.unmark binding) in
let ctxt, param_var = create_var (Option.map Mark.remove binding) in
let case_body =
translate_expr scope inside_definition_of ctxt
case.Surface.Ast.match_case_expr
@ -828,7 +823,7 @@ and disambiguate_match_and_build_expression
[
Some "Not ending wildcard:", case_pos;
( Some "Next reachable case:",
curr_index + 1 |> List.nth cases |> Marked.get_mark );
curr_index + 1 |> List.nth cases |> Mark.get );
]
"Wildcard must be the last match case"
in
@ -903,10 +898,10 @@ let merge_conditions
let op_term =
Expr.eop And
[TLit TBool, default_pos; TLit TBool, default_pos]
(Marked.get_mark cond)
(Mark.get cond)
in
Expr.eapp op_term [precond; cond] (Marked.get_mark cond)
| Some precond, None -> Marked.unmark precond, Untyped { pos = default_pos }
Expr.eapp op_term [precond; cond] (Mark.get cond)
| Some precond, None -> Mark.remove precond, Untyped { pos = default_pos }
| None, Some cond -> cond
| None, None -> Expr.elit (LBool true) (Untyped { pos = default_pos })
@ -938,10 +933,10 @@ let rec arglist_eq_check pos_decl pos_def pdecl pdefs =
let process_rule_parameters
ctxt
(def_key : Ast.ScopeDef.t Marked.pos)
(def_key : Ast.ScopeDef.t Mark.pos)
(def : Surface.Ast.definition) :
Name_resolution.context
* (Ast.expr Var.t Marked.pos * typ) list Marked.pos option =
* (Ast.expr Var.t Mark.pos * typ) list Mark.pos option =
let decl_name, decl_pos = def_key in
let declared_params = Name_resolution.get_params ctxt decl_name in
match declared_params, def.S.definition_parameter with
@ -958,7 +953,7 @@ let process_rule_parameters
[
Some "Arguments declared here", pos;
( Some "Definition missing the arguments",
Marked.get_mark def.Surface.Ast.definition_name );
Mark.get def.Surface.Ast.definition_name );
]
"This definition for %a is missing the arguments" Ast.ScopeDef.format_t
decl_name
@ -978,9 +973,9 @@ let process_rule_parameters
let process_default
(ctxt : Name_resolution.context)
(scope : ScopeName.t)
(def_key : Ast.ScopeDef.t Marked.pos)
(def_key : Ast.ScopeDef.t Mark.pos)
(rule_id : RuleName.t)
(params : (Ast.expr Var.t Marked.pos * typ) list Marked.pos option)
(params : (Ast.expr Var.t Mark.pos * typ) list Mark.pos option)
(precond : Ast.expr boxed option)
(exception_situation : Ast.exception_situation)
(label_situation : Ast.label_situation)
@ -991,7 +986,7 @@ let process_default
| Some just -> Some (translate_expr (Some scope) (Some def_key) ctxt just)
| None -> None
in
let just = merge_conditions precond just (Marked.get_mark def_key) in
let just = merge_conditions precond just (Mark.get def_key) in
let cons = translate_expr (Some scope) (Some def_key) ctxt cons in
{
Ast.rule_just = just;
@ -1014,18 +1009,16 @@ let process_def
let scope_ctxt = ScopeName.Map.find scope_uid ctxt.scopes in
let def_key =
Name_resolution.get_def_key
(Marked.unmark def.definition_name)
(Mark.remove def.definition_name)
def.definition_state scope_uid ctxt
(Marked.get_mark def.definition_name)
(Mark.get def.definition_name)
in
let scope_def_ctxt =
Ast.ScopeDef.Map.find def_key scope_ctxt.scope_defs_contexts
in
(* We add to the name resolution context the name of the parameter variable *)
let new_ctxt, param_uids =
process_rule_parameters ctxt
(Marked.same_mark_as def_key def.definition_name)
def
process_rule_parameters ctxt (Mark.copy def.definition_name def_key) def
in
let scope_updated =
let scope_def = Ast.ScopeDef.Map.find def_key scope.scope_defs in
@ -1051,15 +1044,14 @@ let process_def
| ExceptionToLabel label_str -> (
try
let label_id =
IdentName.Map.find (Marked.unmark label_str)
IdentName.Map.find (Mark.remove label_str)
scope_def_ctxt.label_idmap
in
ExceptionToLabel (label_id, Marked.get_mark label_str)
ExceptionToLabel (label_id, Mark.get label_str)
with Not_found ->
Errors.raise_spanned_error
(Marked.get_mark label_str)
Errors.raise_spanned_error (Mark.get label_str)
"Unknown label for the scope variable %a: \"%s\""
Ast.ScopeDef.format_t def_key (Marked.unmark label_str))
Ast.ScopeDef.format_t def_key (Mark.remove label_str))
in
let scope_def =
{
@ -1067,7 +1059,7 @@ let process_def
scope_def_rules =
RuleName.Map.add rule_name
(process_default new_ctxt scope_uid
(def_key, Marked.get_mark def.definition_name)
(def_key, Mark.get def.definition_name)
rule_name param_uids precond exception_situation label_situation
def.definition_condition def.definition_expr)
scope_def.scope_def_rules;
@ -1110,16 +1102,15 @@ let process_assert
( Surface.Ast.IfThenElse
( cond,
ass.Surface.Ast.assertion_content,
Marked.same_mark_as (Surface.Ast.Literal (Surface.Ast.LBool true))
cond ),
Marked.get_mark cond ))
Mark.copy cond (Surface.Ast.Literal (Surface.Ast.LBool true)) ),
Mark.get cond ))
in
let assertion =
match precond with
| Some precond ->
Expr.eifthenelse precond ass
(Expr.elit (LBool true) (Marked.get_mark precond))
(Marked.get_mark precond)
(Expr.elit (LBool true) (Mark.get precond))
(Mark.get precond)
| None -> ass
in
(* The assertion name is not very relevant and should not be used in error
@ -1145,9 +1136,9 @@ let process_scope_use_item
(scope : ScopeName.t)
(ctxt : Name_resolution.context)
(prgm : Ast.program)
(item : Surface.Ast.scope_use_item Marked.pos) : Ast.program =
(item : Surface.Ast.scope_use_item Mark.pos) : Ast.program =
let precond = Option.map (translate_expr (Some scope) None ctxt) precond in
match Marked.unmark item with
match Mark.remove item with
| Surface.Ast.Rule rule -> process_rule precond scope ctxt prgm rule
| Surface.Ast.Definition def -> process_def precond scope ctxt prgm def
| Surface.Ast.Assertion ass -> process_assert precond scope ctxt prgm ass
@ -1169,13 +1160,13 @@ let process_scope_use_item
with
| Some (_, old_pos) ->
Errors.raise_multispanned_error
[None, old_pos; None, Marked.get_mark item]
[None, old_pos; None, Mark.get item]
"You cannot set multiple date rounding modes"
| None ->
{
scope with
scope_options =
Marked.same_mark_as (Ast.DateRounding r) item :: scope.scope_options;
Mark.copy item (Ast.DateRounding r) :: scope.scope_options;
}
in
{
@ -1191,23 +1182,22 @@ let process_scope_use_item
let check_unlabeled_exception
(scope : ScopeName.t)
(ctxt : Name_resolution.context)
(item : Surface.Ast.scope_use_item Marked.pos) : unit =
(item : Surface.Ast.scope_use_item Mark.pos) : unit =
let scope_ctxt = ScopeName.Map.find scope ctxt.scopes in
match Marked.unmark item with
match Mark.remove item with
| Surface.Ast.Rule _ | Surface.Ast.Definition _ -> (
let def_key, exception_to =
match Marked.unmark item with
match Mark.remove item with
| Surface.Ast.Rule rule ->
( Name_resolution.get_def_key
(Marked.unmark rule.rule_name)
rule.rule_state scope ctxt
(Marked.get_mark rule.rule_name),
(Mark.remove rule.rule_name)
rule.rule_state scope ctxt (Mark.get rule.rule_name),
rule.rule_exception_to )
| Surface.Ast.Definition def ->
( Name_resolution.get_def_key
(Marked.unmark def.definition_name)
(Mark.remove def.definition_name)
def.definition_state scope ctxt
(Marked.get_mark def.definition_name),
(Mark.get def.definition_name),
def.definition_exception_to )
| _ -> assert false
(* should not happen *)
@ -1222,11 +1212,11 @@ let check_unlabeled_exception
| Surface.Ast.UnlabeledException -> (
match scope_def_ctxt.default_exception_rulename with
| None ->
Errors.raise_spanned_error (Marked.get_mark item)
Errors.raise_spanned_error (Mark.get item)
"This exception does not have a corresponding definition"
| Some (Ambiguous pos) ->
Errors.raise_multispanned_error
([Some "Ambiguous exception", Marked.get_mark item]
([Some "Ambiguous exception", Mark.get item]
@ List.map (fun p -> Some "Candidate definition", p) pos)
"This exception can refer to several definitions. Try using labels \
to disambiguate"
@ -1258,7 +1248,7 @@ let process_topdef
(def : S.top_def) : Ast.program =
let id =
IdentName.Map.find
(Marked.unmark def.S.topdef_name)
(Mark.remove def.S.topdef_name)
ctxt.Name_resolution.topdefs
in
let translate_typ t = Name_resolution.process_type ctxt t in
@ -1278,10 +1268,10 @@ let process_topdef
let body = translate_expr None None ctxt def.S.topdef_expr in
let args, tys = List.split args_tys in
Expr.make_abs
(Array.of_list (List.map Marked.unmark args))
(Array.of_list (List.map Mark.remove args))
body
(List.map translate_tbase tys)
(Marked.get_mark def.S.topdef_name)
(Mark.get def.S.topdef_name)
in
{
prgm with
@ -1293,7 +1283,7 @@ let attribute_to_io (attr : Surface.Ast.scope_decl_context_io) : Ast.io =
{
Ast.io_output = attr.scope_decl_context_io_output;
Ast.io_input =
Marked.map_under_mark
Mark.map
(fun io ->
match io with
| Surface.Ast.Input -> Ast.OnlyInput
@ -1343,12 +1333,11 @@ let init_scope_defs
(let original_io = attribute_to_io v_sig.var_sig_io in
let io_input =
if i = 0 then original_io.io_input
else
Ast.NoInput, Marked.get_mark (StateName.get_info state)
else Ast.NoInput, Mark.get (StateName.get_info state)
in
let io_output =
if i = List.length states - 1 then original_io.io_output
else false, Marked.get_mark (StateName.get_info state)
else false, Mark.get (StateName.get_info state)
in
{ io_input; io_output });
}
@ -1370,8 +1359,7 @@ let init_scope_defs
? *)
let v_sig = ScopeVar.Map.find v ctxt.Name_resolution.var_typs in
let def_key =
Ast.ScopeDef.SubScopeVar
(v0, v, Marked.get_mark (ScopeVar.get_info v))
Ast.ScopeDef.SubScopeVar (v0, v, Mark.get (ScopeVar.get_info v))
in
Ast.ScopeDef.Map.add def_key
{
@ -1456,7 +1444,7 @@ let translate_program
| CodeBlock (block, _, _) ->
List.fold_left
(fun prgm item ->
match Marked.unmark item with
match Mark.remove item with
| Surface.Ast.ScopeUse use -> process_scope_use ctxt prgm use
| Surface.Ast.Topdef def -> process_topdef ctxt prgm def
| Surface.Ast.ScopeDecl _ | Surface.Ast.StructDecl _

12
compiler/desugared/linting.ml
View File

@ -29,7 +29,7 @@ let detect_empty_definitions (p : program) : unit =
&& RuleName.Map.is_empty scope_def.scope_def_rules
&& (not scope_def.scope_def_is_condition)
&&
match Marked.unmark scope_def.scope_def_io.io_input with
match Mark.remove scope_def.scope_def_io.io_input with
| Ast.NoInput -> true
| _ -> false
then
@ -105,9 +105,9 @@ let detect_unused_scope_vars (p : program) : unit =
Ast.fold_exprs
~f:(fun used_scope_vars e ->
let rec used_scope_vars_expr e used_scope_vars =
match Marked.unmark e with
match Mark.remove e with
| ELocation (DesugaredScopeVar (v, _)) ->
ScopeVar.Set.add (Marked.unmark v) used_scope_vars
ScopeVar.Set.add (Mark.remove v) used_scope_vars
| _ -> Expr.shallow_fold used_scope_vars_expr e used_scope_vars
in
used_scope_vars_expr e used_scope_vars)
@ -120,7 +120,7 @@ let detect_unused_scope_vars (p : program) : unit =
match scope_def_key with
| ScopeDef.Var (v, _)
when (not (ScopeVar.Set.mem v used_scope_vars))
&& not (Marked.unmark scope_def.scope_def_io.io_output) ->
&& not (Mark.remove scope_def.scope_def_io.io_output) ->
Errors.format_spanned_warning
(ScopeDef.get_position scope_def_key)
"In scope %a, the variable %a is never used anywhere; maybe it's \
@ -141,7 +141,7 @@ let detect_unused_struct_fields (p : program) : unit =
Ast.fold_exprs
~f:(fun struct_fields_used e ->
let rec structs_fields_used_expr e struct_fields_used =
match Marked.unmark e with
match Mark.remove e with
| EDStructAccess { name_opt = Some name; e = e_struct; field } ->
let field =
StructName.Map.find name
@ -206,7 +206,7 @@ let detect_unused_enum_constructors (p : program) : unit =
Ast.fold_exprs
~f:(fun enum_constructors_used e ->
let rec enum_constructors_used_expr e enum_constructors_used =
match Marked.unmark e with
match Mark.remove e with
| EInj { name = _; e = e_enum; cons } ->
EnumConstructor.Set.add cons
(enum_constructors_used_expr e_enum enum_constructors_used)

168
compiler/desugared/name_resolution.ml
View File

@ -23,9 +23,7 @@ open Shared_ast
(** {1 Name resolution context} *)
type unique_rulename =
| Ambiguous of Pos.t list
| Unique of RuleName.t Marked.pos
type unique_rulename = Ambiguous of Pos.t list | Unique of RuleName.t Mark.pos
type scope_def_context = {
default_exception_rulename : unique_rulename option;
@ -56,7 +54,7 @@ type var_sig = {
var_sig_typ : typ;
var_sig_is_condition : bool;
var_sig_parameters :
(Uid.MarkedString.info * Shared_ast.typ) list Marked.pos option;
(Uid.MarkedString.info * Shared_ast.typ) list Mark.pos option;
var_sig_io : Surface.Ast.scope_decl_context_io;
var_sig_states_idmap : StateName.t IdentName.Map.t;
var_sig_states_list : StateName.t list;
@ -101,10 +99,9 @@ let raise_unsupported_feature (msg : string) (pos : Pos.t) =
(** Function to call whenever an identifier used somewhere has not been declared
in the program previously *)
let raise_unknown_identifier (msg : string) (ident : IdentName.t Marked.pos) =
Errors.raise_spanned_error (Marked.get_mark ident)
"\"%s\": unknown identifier %s"
(Cli.with_style [ANSITerminal.yellow] "%s" (Marked.unmark ident))
let raise_unknown_identifier (msg : string) (ident : IdentName.t Mark.pos) =
Errors.raise_spanned_error (Mark.get ident) "\"%s\": unknown identifier %s"
(Cli.with_style [ANSITerminal.yellow] "%s" (Mark.remove ident))
msg
(** Gets the type associated to an uid *)
@ -122,7 +119,7 @@ let get_var_io (ctxt : context) (uid : ScopeVar.t) :
let get_var_uid
(scope_uid : ScopeName.t)
(ctxt : context)
((x, pos) : IdentName.t Marked.pos) : ScopeVar.t =
((x, pos) : IdentName.t Mark.pos) : ScopeVar.t =
let scope = ScopeName.Map.find scope_uid ctxt.scopes in
match IdentName.Map.find_opt x scope.var_idmap with
| Some (ScopeVar uid) -> uid
@ -135,7 +132,7 @@ let get_var_uid
let get_subscope_uid
(scope_uid : ScopeName.t)
(ctxt : context)
((y, pos) : IdentName.t Marked.pos) : SubScopeName.t =
((y, pos) : IdentName.t Mark.pos) : SubScopeName.t =
let scope = ScopeName.Map.find scope_uid ctxt.scopes in
match IdentName.Map.find_opt y scope.var_idmap with
| Some (SubScope (sub_uid, _sub_id)) -> sub_uid
@ -171,7 +168,7 @@ let get_def_typ (ctxt : context) (def : Ast.ScopeDef.t) : typ =
(** Retrieves the type of a scope definition from the context *)
let get_params (ctxt : context) (def : Ast.ScopeDef.t) :
(Uid.MarkedString.info * typ) list Marked.pos option =
(Uid.MarkedString.info * typ) list Mark.pos option =
match def with
| Ast.ScopeDef.SubScopeVar (_, x, _)
(* we don't need to look at the subscope prefix because [x] is already the uid
@ -188,60 +185,60 @@ let is_def_cond (ctxt : context) (def : Ast.ScopeDef.t) : bool =
is_var_cond ctxt x
let get_enum ctxt id =
match IdentName.Map.find (Marked.unmark id) ctxt.typedefs with
match IdentName.Map.find (Mark.remove id) ctxt.typedefs with
| TEnum id -> id
| TStruct sid ->
Errors.raise_multispanned_error
[
None, Marked.get_mark id;
Some "Structure defined at", Marked.get_mark (StructName.get_info sid);
None, Mark.get id;
Some "Structure defined at", Mark.get (StructName.get_info sid);
]
"Expecting an enum, but found a structure"
| TScope (sid, _) ->
Errors.raise_multispanned_error
[
None, Marked.get_mark id;
Some "Scope defined at", Marked.get_mark (ScopeName.get_info sid);
None, Mark.get id;
Some "Scope defined at", Mark.get (ScopeName.get_info sid);
]
"Expecting an enum, but found a scope"
| exception Not_found ->
Errors.raise_spanned_error (Marked.get_mark id) "No enum named %s found"
(Marked.unmark id)
Errors.raise_spanned_error (Mark.get id) "No enum named %s found"
(Mark.remove id)
let get_struct ctxt id =
match IdentName.Map.find (Marked.unmark id) ctxt.typedefs with
match IdentName.Map.find (Mark.remove id) ctxt.typedefs with
| TStruct id | TScope (_, { out_struct_name = id; _ }) -> id
| TEnum eid ->
Errors.raise_multispanned_error
[
None, Marked.get_mark id;
Some "Enum defined at", Marked.get_mark (EnumName.get_info eid);
None, Mark.get id;
Some "Enum defined at", Mark.get (EnumName.get_info eid);
]
"Expecting an struct, but found an enum"
| exception Not_found ->
Errors.raise_spanned_error (Marked.get_mark id) "No struct named %s found"
(Marked.unmark id)
Errors.raise_spanned_error (Mark.get id) "No struct named %s found"
(Mark.remove id)
let get_scope ctxt id =
match IdentName.Map.find (Marked.unmark id) ctxt.typedefs with
match IdentName.Map.find (Mark.remove id) ctxt.typedefs with
| TScope (id, _) -> id
| TEnum eid ->
Errors.raise_multispanned_error
[
None, Marked.get_mark id;
Some "Enum defined at", Marked.get_mark (EnumName.get_info eid);
None, Mark.get id;
Some "Enum defined at", Mark.get (EnumName.get_info eid);
]
"Expecting an scope, but found an enum"
| TStruct sid ->
Errors.raise_multispanned_error
[
None, Marked.get_mark id;
Some "Structure defined at", Marked.get_mark (StructName.get_info sid);
None, Mark.get id;
Some "Structure defined at", Mark.get (StructName.get_info sid);
]
"Expecting an scope, but found a structure"
| exception Not_found ->
Errors.raise_spanned_error (Marked.get_mark id) "No scope named %s found"
(Marked.unmark id)
Errors.raise_spanned_error (Mark.get id) "No scope named %s found"
(Mark.remove id)
(** {1 Declarations pass} *)
@ -261,7 +258,7 @@ let process_subscope_decl
| SubScope (ssc, _) -> SubScopeName.get_info ssc
in
Errors.raise_multispanned_error
[Some "first use", Marked.get_mark info; Some "second use", s_pos]
[Some "first use", Mark.get info; Some "second use", s_pos]
"Subscope name \"%a\" already used"
(Cli.format_with_style [ANSITerminal.yellow])
subscope
@ -293,13 +290,12 @@ let is_type_cond ((typ, _) : Surface.Ast.typ) =
(** Process a basic type (all types except function types) *)
let rec process_base_typ
(ctxt : context)
((typ, typ_pos) : Surface.Ast.base_typ Marked.pos) : typ =
((typ, typ_pos) : Surface.Ast.base_typ Mark.pos) : typ =
match typ with
| Surface.Ast.Condition -> TLit TBool, typ_pos
| Surface.Ast.Data (Surface.Ast.Collection t) ->
( TArray
(process_base_typ ctxt
(Surface.Ast.Data (Marked.unmark t), Marked.get_mark t)),
(process_base_typ ctxt (Surface.Ast.Data (Mark.remove t), Mark.get t)),
typ_pos )
| Surface.Ast.Data (Surface.Ast.Primitive prim) -> (
match prim with
@ -352,7 +348,7 @@ let process_data_decl
| SubScope (ssc, _) -> SubScopeName.get_info ssc
in
Errors.raise_multispanned_error
[Some "First use:", Marked.get_mark info; Some "Second use:", pos]
[Some "First use:", Mark.get info; Some "Second use:", pos]
"Variable name \"%a\" already used"
(Cli.format_with_style [ANSITerminal.yellow])
name
@ -368,7 +364,7 @@ let process_data_decl
List.fold_right
(fun state_id
((states_idmap : StateName.t IdentName.Map.t), states_list) ->
let state_id_name = Marked.unmark state_id in
let state_id_name = Mark.remove state_id in
if IdentName.Map.mem state_id_name states_idmap then
Errors.raise_multispanned_error
[
@ -376,12 +372,12 @@ let process_data_decl
(Format.asprintf "First instance of state %a:"
(Cli.format_with_style [ANSITerminal.yellow])
("\"" ^ state_id_name ^ "\"")),
Marked.get_mark state_id );
Mark.get state_id );
( Some
(Format.asprintf "Second instance of state %a:"
(Cli.format_with_style [ANSITerminal.yellow])
("\"" ^ state_id_name ^ "\"")),
Marked.get_mark
Mark.get
(IdentName.Map.find state_id_name states_idmap
|> StateName.get_info) );
]
@ -394,8 +390,7 @@ let process_data_decl
in
let var_sig_parameters =
Option.map
(Marked.map_under_mark
(List.map (fun (lbl, typ) -> lbl, process_type ctxt typ)))
(Mark.map (List.map (fun (lbl, typ) -> lbl, process_type ctxt typ)))
decl.scope_decl_context_item_parameters
in
{
@ -433,10 +428,10 @@ let process_struct_decl (ctxt : context) (sdecl : Surface.Ast.struct_decl) :
let s_uid = get_struct ctxt sdecl.struct_decl_name in
if sdecl.struct_decl_fields = [] then
Errors.raise_spanned_error
(Marked.get_mark sdecl.struct_decl_name)
(Mark.get sdecl.struct_decl_name)
"The struct %s does not have any fields; give it some for Catala to be \
able to accept it."
(Marked.unmark sdecl.struct_decl_name);
(Mark.remove sdecl.struct_decl_name);
List.fold_left
(fun ctxt (fdecl, _) ->
let f_uid = StructField.fresh fdecl.Surface.Ast.struct_decl_field_name in
@ -445,7 +440,7 @@ let process_struct_decl (ctxt : context) (sdecl : Surface.Ast.struct_decl) :
ctxt with
field_idmap =
IdentName.Map.update
(Marked.unmark fdecl.Surface.Ast.struct_decl_field_name)
(Mark.remove fdecl.Surface.Ast.struct_decl_field_name)
(fun uids ->
match uids with
| None -> Some (StructName.Map.singleton s_uid f_uid)
@ -478,10 +473,10 @@ let process_enum_decl (ctxt : context) (edecl : Surface.Ast.enum_decl) : context
let e_uid = get_enum ctxt edecl.enum_decl_name in
if List.length edecl.enum_decl_cases = 0 then
Errors.raise_spanned_error
(Marked.get_mark edecl.enum_decl_name)
(Mark.get edecl.enum_decl_name)
"The enum %s does not have any cases; give it some for Catala to be able \
to accept it."
(Marked.unmark edecl.enum_decl_name);
(Mark.remove edecl.enum_decl_name);
List.fold_left
(fun ctxt (cdecl, cdecl_pos) ->
let c_uid = EnumConstructor.fresh cdecl.Surface.Ast.enum_decl_case_name in
@ -490,7 +485,7 @@ let process_enum_decl (ctxt : context) (edecl : Surface.Ast.enum_decl) : context
ctxt with
constructor_idmap =
IdentName.Map.update
(Marked.unmark cdecl.Surface.Ast.enum_decl_case_name)
(Mark.remove cdecl.Surface.Ast.enum_decl_case_name)
(fun uids ->
match uids with
| None -> Some (EnumName.Map.singleton e_uid c_uid)
@ -531,21 +526,21 @@ let process_scope_decl (ctxt : context) (decl : Surface.Ast.scope_decl) :
let scope_uid = get_scope ctxt decl.scope_decl_name in
let ctxt =
List.fold_left
(fun ctxt item -> process_item_decl scope_uid ctxt (Marked.unmark item))
(fun ctxt item -> process_item_decl scope_uid ctxt (Mark.remove item))
ctxt decl.scope_decl_context
in
(* Add an implicit struct def for the scope output type *)
let output_fields =
List.fold_right
(fun item acc ->
match Marked.unmark item with
match Mark.remove item with
| Surface.Ast.ContextData
({
scope_decl_context_item_attribute =
{ scope_decl_context_io_output = true, _; _ };
_;
} as data) ->
Marked.mark (Marked.get_mark item)
Mark.add (Mark.get item)
{
Surface.Ast.struct_decl_field_name =
data.scope_decl_context_item_name;
@ -592,7 +587,7 @@ let process_scope_decl (ctxt : context) (decl : Surface.Ast.scope_decl) :
in
let typedefs =
IdentName.Map.update
(Marked.unmark decl.scope_decl_name)
(Mark.remove decl.scope_decl_name)
(function
| Some (TScope (scope, { out_struct_name; _ })) ->
Some (TScope (scope, { out_struct_name; out_struct_fields }))
@ -607,19 +602,16 @@ let typedef_info = function
| TScope (s, _) -> ScopeName.get_info s
(** Process the names of all declaration items *)
let process_name_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
: context =
let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
context =
let raise_already_defined_error (use : Uid.MarkedString.info) name pos msg =
Errors.raise_multispanned_error
[
Some "First definition:", Marked.get_mark use;
Some "Second definition:", pos;
]
[Some "First definition:", Mark.get use; Some "Second definition:", pos]
"%s name \"%a\" already defined" msg
(Cli.format_with_style [ANSITerminal.yellow])
name
in
match Marked.unmark item with
match Mark.remove item with
| ScopeDecl decl ->
let name, pos = decl.scope_decl_name in
(* Checks if the name is already used *)
@ -660,7 +652,7 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
ctxt with
typedefs =
IdentName.Map.add
(Marked.unmark sdecl.struct_decl_name)
(Mark.remove sdecl.struct_decl_name)
(TStruct s_uid) ctxt.typedefs;
}
| EnumDecl edecl ->
@ -674,7 +666,7 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
ctxt with
typedefs =
IdentName.Map.add
(Marked.unmark edecl.enum_decl_name)
(Mark.remove edecl.enum_decl_name)
(TEnum e_uid) ctxt.typedefs;
}
| ScopeUse _ -> ctxt
@ -689,9 +681,9 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
{ ctxt with topdefs = IdentName.Map.add name uid ctxt.topdefs }
(** Process a code item that is a declaration *)
let process_decl_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
: context =
match Marked.unmark item with
let process_decl_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
context =
match Mark.remove item with
| ScopeDecl decl -> process_scope_decl ctxt decl
| StructDecl sdecl -> process_struct_decl ctxt sdecl
| EnumDecl edecl -> process_enum_decl ctxt edecl
@ -702,7 +694,7 @@ let process_decl_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
let process_code_block
(ctxt : context)
(block : Surface.Ast.code_block)
(process_item : context -> Surface.Ast.code_item Marked.pos -> context) :
(process_item : context -> Surface.Ast.code_item Mark.pos -> context) :
context =
List.fold_left (fun ctxt decl -> process_item ctxt decl) ctxt block
@ -710,7 +702,7 @@ let process_code_block
let rec process_law_structure
(ctxt : context)
(s : Surface.Ast.law_structure)
(process_item : context -> Surface.Ast.code_item Marked.pos -> context) :
(process_item : context -> Surface.Ast.code_item Mark.pos -> context) :
context =
match s with
| Surface.Ast.LawHeading (_, children) ->
@ -725,7 +717,7 @@ let rec process_law_structure
let get_def_key
(name : Surface.Ast.scope_var)
(state : Surface.Ast.lident Marked.pos option)
(state : Surface.Ast.lident Mark.pos option)
(scope_uid : ScopeName.t)
(ctxt : context)
(pos : Pos.t) : Ast.ScopeDef.t =
@ -740,14 +732,13 @@ let get_def_key
| Some state -> (
try
Some
(IdentName.Map.find (Marked.unmark state)
(IdentName.Map.find (Mark.remove state)
var_sig.var_sig_states_idmap)
with Not_found ->
Errors.raise_multispanned_error
[
None, Marked.get_mark state;
( Some "Variable declaration:",
Marked.get_mark (ScopeVar.get_info x_uid) );
None, Mark.get state;
Some "Variable declaration:", Mark.get (ScopeVar.get_info x_uid);
]
"This identifier is not a state declared for variable %a."
ScopeVar.format_t x_uid)
@ -755,9 +746,8 @@ let get_def_key
if not (IdentName.Map.is_empty var_sig.var_sig_states_idmap) then
Errors.raise_multispanned_error
[
None, Marked.get_mark x;
( Some "Variable declaration:",
Marked.get_mark (ScopeVar.get_info x_uid) );
None, Mark.get x;
Some "Variable declaration:", Mark.get (ScopeVar.get_info x_uid);
]
"This definition does not indicate which state has to be \
considered for variable %a."
@ -765,15 +755,15 @@ let get_def_key
else None )
| [y; x] ->
let (subscope_uid, subscope_real_uid) : SubScopeName.t * ScopeName.t =
match IdentName.Map.find_opt (Marked.unmark y) scope_ctxt.var_idmap with
match IdentName.Map.find_opt (Mark.remove y) scope_ctxt.var_idmap with
| Some (SubScope (v, u)) -> v, u
| Some _ ->
Errors.raise_spanned_error pos
"Invalid access to input variable, %a is not a subscope"
Print.lit_style (Marked.unmark y)
Print.lit_style (Mark.remove y)
| None ->
Errors.raise_spanned_error pos "No definition found for subscope %a"
Print.lit_style (Marked.unmark y)
Print.lit_style (Mark.remove y)
in
let x_uid = get_var_uid subscope_real_uid ctxt x in
Ast.ScopeDef.SubScopeVar (subscope_uid, x_uid, pos)
@ -793,7 +783,7 @@ let update_def_key_ctx
| None -> def_key_ctx
| Some label ->
let new_label_idmap =
IdentName.Map.update (Marked.unmark label)
IdentName.Map.update (Mark.remove label)
(fun existing_label ->
match existing_label with
| Some existing_label -> Some existing_label
@ -818,7 +808,7 @@ let update_def_key_ctx
default_exception_rulename =
Some
(Ambiguous
([Marked.get_mark d.definition_name]
([Mark.get d.definition_name]
@
match old with Ambiguous old -> old | Unique (_, pos) -> [pos]));
}
@ -831,7 +821,7 @@ let update_def_key_ctx
{
def_key_ctx with
default_exception_rulename =
Some (Ambiguous [Marked.get_mark d.definition_name]);
Some (Ambiguous [Mark.get d.definition_name]);
}
(* This is a possible default definition for this key. We create and store
a fresh rulename *)
@ -839,7 +829,7 @@ let update_def_key_ctx
{
def_key_ctx with
default_exception_rulename =
Some (Unique (d.definition_id, Marked.get_mark d.definition_name));
Some (Unique (d.definition_id, Mark.get d.definition_name));
}))
let empty_def_key_ctx =
@ -862,9 +852,9 @@ let process_definition
(fun (s_ctxt : scope_context option) ->
let def_key =
get_def_key
(Marked.unmark d.definition_name)
(Mark.remove d.definition_name)
d.definition_state s_name ctxt
(Marked.get_mark d.definition_name)
(Mark.get d.definition_name)
in
match s_ctxt with
| None -> assert false (* should not happen *)
@ -886,8 +876,8 @@ let process_definition
let process_scope_use_item
(s_name : ScopeName.t)
(ctxt : context)
(sitem : Surface.Ast.scope_use_item Marked.pos) : context =
match Marked.unmark sitem with
(sitem : Surface.Ast.scope_use_item Mark.pos) : context =
match Mark.remove sitem with
| Rule r -> process_definition ctxt s_name (Surface.Ast.rule_to_def r)
| Definition d -> process_definition ctxt s_name d
| _ -> ctxt
@ -897,24 +887,24 @@ let process_scope_use (ctxt : context) (suse : Surface.Ast.scope_use) : context
let s_name =
match
IdentName.Map.find_opt
(Marked.unmark suse.Surface.Ast.scope_use_name)
(Mark.remove suse.Surface.Ast.scope_use_name)
ctxt.typedefs
with
| Some (TScope (sn, _)) -> sn
| _ ->
Errors.raise_spanned_error
(Marked.get_mark suse.Surface.Ast.scope_use_name)
(Mark.get suse.Surface.Ast.scope_use_name)
"\"%a\": this scope has not been declared anywhere, is it a typo?"
(Cli.format_with_style [ANSITerminal.yellow])
(Marked.unmark suse.Surface.Ast.scope_use_name)
(Mark.remove suse.Surface.Ast.scope_use_name)
in
List.fold_left
(process_scope_use_item s_name)
ctxt suse.Surface.Ast.scope_use_items
let process_use_item (ctxt : context) (item : Surface.Ast.code_item Marked.pos)
: context =
match Marked.unmark item with
let process_use_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
context =
match Mark.remove item with
| ScopeDecl _ | StructDecl _ | EnumDecl _ | Topdef _ -> ctxt
| ScopeUse suse -> process_scope_use ctxt suse

22
compiler/desugared/name_resolution.mli
View File

@ -23,9 +23,7 @@ open Shared_ast
(** {1 Name resolution context} *)
type unique_rulename =
| Ambiguous of Pos.t list
| Unique of RuleName.t Marked.pos
type unique_rulename = Ambiguous of Pos.t list | Unique of RuleName.t Mark.pos
type scope_def_context = {
default_exception_rulename : unique_rulename option;
@ -56,7 +54,7 @@ type var_sig = {
var_sig_typ : typ;
var_sig_is_condition : bool;
var_sig_parameters :
(Uid.MarkedString.info * Shared_ast.typ) list Marked.pos option;
(Uid.MarkedString.info * Shared_ast.typ) list Mark.pos option;
var_sig_io : Surface.Ast.scope_decl_context_io;
var_sig_states_idmap : StateName.t IdentName.Map.t;
var_sig_states_list : StateName.t list;
@ -98,7 +96,7 @@ val raise_unsupported_feature : string -> Pos.t -> 'a
(** Temporary function raising an error message saying that a feature is not
supported yet *)
val raise_unknown_identifier : string -> IdentName.t Marked.pos -> 'a
val raise_unknown_identifier : string -> IdentName.t Mark.pos -> 'a
(** Function to call whenever an identifier used somewhere has not been declared
in the program previously *)
@ -108,11 +106,11 @@ val get_var_typ : context -> ScopeVar.t -> typ
val is_var_cond : context -> ScopeVar.t -> bool
val get_var_io : context -> ScopeVar.t -> Surface.Ast.scope_decl_context_io
val get_var_uid : ScopeName.t -> context -> IdentName.t Marked.pos -> ScopeVar.t
val get_var_uid : ScopeName.t -> context -> IdentName.t Mark.pos -> ScopeVar.t
(** Get the variable uid inside the scope given in argument *)
val get_subscope_uid :
ScopeName.t -> context -> IdentName.t Marked.pos -> SubScopeName.t
ScopeName.t -> context -> IdentName.t Mark.pos -> SubScopeName.t
(** Get the subscope uid inside the scope given in argument *)
val is_subscope_uid : ScopeName.t -> context -> IdentName.t -> bool
@ -128,7 +126,7 @@ val get_def_typ : context -> Ast.ScopeDef.t -> typ
val get_params :
context ->
Ast.ScopeDef.t ->
(Uid.MarkedString.info * typ) list Marked.pos option
(Uid.MarkedString.info * typ) list Mark.pos option
val is_def_cond : context -> Ast.ScopeDef.t -> bool
val is_type_cond : Surface.Ast.typ -> bool
@ -138,22 +136,22 @@ val add_def_local_var : context -> IdentName.t -> context * Ast.expr Var.t
val get_def_key :
Surface.Ast.scope_var ->
Surface.Ast.lident Marked.pos option ->
Surface.Ast.lident Mark.pos option ->
ScopeName.t ->
context ->
Pos.t ->
Ast.ScopeDef.t
(** Usage: [get_def_key var_name var_state scope_uid ctxt pos]*)
val get_enum : context -> IdentName.t Marked.pos -> EnumName.t
val get_enum : context -> IdentName.t Mark.pos -> EnumName.t
(** Find an enum definition from the typedefs, failing if there is none or it
has a different kind *)
val get_struct : context -> IdentName.t Marked.pos -> StructName.t
val get_struct : context -> IdentName.t Mark.pos -> StructName.t
(** Find a struct definition from the typedefs (possibly an implicit output
struct from a scope), failing if there is none or it has a different kind *)
val get_scope : context -> IdentName.t Marked.pos -> ScopeName.t
val get_scope : context -> IdentName.t Mark.pos -> ScopeName.t
(** Find a scope definition from the typedefs, failing if there is none or it
has a different kind *)

31
compiler/lcalc/closure_conversion.ml
View File

@ -28,16 +28,15 @@ type 'm ctx = {
globally_bound_vars : 'm expr Var.Set.t;
}
let tys_as_tanys tys =
List.map (fun x -> Marked.map_under_mark (fun _ -> TAny) x) tys
let tys_as_tanys tys = List.map (fun x -> Mark.map (fun _ -> TAny) x) tys
type 'm hoisted_closure = { name : 'm expr Var.t; closure : 'm expr }
let rec hoist_context_free_closures :
type m. m ctx -> m expr -> m hoisted_closure list * m expr boxed =
fun ctx e ->
let m = Marked.get_mark e in
match Marked.unmark e with
let m = Mark.get e in
match Mark.remove e with
| EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _ | EArray _
| ELit _ | EAssert _ | EOp _ | EIfThenElse _ | ERaise _ | ECatch _ | EVar _ ->
Expr.map_gather ~acc:[] ~join:( @ ) ~f:(hoist_context_free_closures ctx) e
@ -48,7 +47,7 @@ let rec hoist_context_free_closures :
let collected_closures, new_cases =
EnumConstructor.Map.fold
(fun cons e1 (collected_closures, new_cases) ->
match Marked.unmark e1 with
match Mark.remove e1 with
| EAbs { binder; tys } ->
let vars, body = Bindlib.unmbind binder in
let new_collected_closures, new_body =
@ -57,7 +56,7 @@ let rec hoist_context_free_closures :
let new_binder = Expr.bind vars new_body in
( collected_closures @ new_collected_closures,
EnumConstructor.Map.add cons
(Expr.eabs new_binder tys (Marked.get_mark e1))
(Expr.eabs new_binder tys (Mark.get e1))
new_cases )
| _ -> failwith "should not happen")
cases
@ -96,8 +95,8 @@ let rec hoist_context_free_closures :
let rec transform_closures_expr :
type m. m ctx -> m expr -> m expr Var.Set.t * m expr boxed =
fun ctx e ->
let m = Marked.get_mark e in
match Marked.unmark e with
let m = Mark.get e in
match Mark.remove e with
| EStruct _ | EStructAccess _ | ETuple _ | ETupleAccess _ | EInj _ | EArray _
| ELit _ | EAssert _ | EOp _ | EIfThenElse _ | ERaise _ | ECatch _ ->
Expr.map_gather ~acc:Var.Set.empty ~join:Var.Set.union
@ -114,14 +113,14 @@ let rec transform_closures_expr :
let free_vars, new_cases =
EnumConstructor.Map.fold
(fun cons e1 (free_vars, new_cases) ->
match Marked.unmark e1 with
match Mark.remove e1 with
| EAbs { binder; tys } ->
let vars, body = Bindlib.unmbind binder in
let new_free_vars, new_body = (transform_closures_expr ctx) body in
let new_binder = Expr.bind vars new_body in
( Var.Set.union free_vars new_free_vars,
EnumConstructor.Map.add cons
(Expr.eabs new_binder tys (Marked.get_mark e1))
(Expr.eabs new_binder tys (Mark.get e1))
new_cases )
| _ -> failwith "should not happen")
cases
@ -220,7 +219,7 @@ let rec transform_closures_expr :
args (free_vars, [])
in
let call_expr =
let m1 = Marked.get_mark e1 in
let m1 = Mark.get e1 in
Expr.make_let_in code_var
(TAny, Expr.pos e)
(Expr.etupleaccess (Bindlib.box_var code_env_var, m1) 0 2 m)
@ -257,7 +256,7 @@ let closure_conversion_scope_let ctx scope_body_expr =
scope_let with
scope_let_next;
scope_let_expr;
scope_let_typ = Marked.same_mark_as TAny scope_let.scope_let_typ;
scope_let_typ = Mark.copy scope_let.scope_let_typ TAny;
})
(Bindlib.bind_var var_next acc)
(Expr.Box.lift new_scope_let_expr))
@ -283,7 +282,7 @@ let closure_conversion (p : 'm program) : 'm program Bindlib.box =
let ctx =
{
decl_ctx = p.decl_ctx;
name_context = Marked.unmark (ScopeName.get_info name);
name_context = Mark.remove (ScopeName.get_info name);
globally_bound_vars = toplevel_vars;
}
in
@ -300,9 +299,7 @@ let closure_conversion (p : 'm program) : 'm program Bindlib.box =
that a later re-typing phase can infer them. *)
let replace_type_with_any s =
Some
(StructField.Map.map
(fun t -> Marked.same_mark_as TAny t)
(Option.get s))
(StructField.Map.map (fun t -> Mark.copy t TAny) (Option.get s))
in
{
decl_ctx with
@ -322,7 +319,7 @@ let closure_conversion (p : 'm program) : 'm program Bindlib.box =
let ctx =
{
decl_ctx = p.decl_ctx;
name_context = Marked.unmark (TopdefName.get_info name);
name_context = Mark.remove (TopdefName.get_info name);
globally_bound_vars = toplevel_vars;
}
in

16
compiler/lcalc/compile_with_exceptions.ml
View File

@ -27,7 +27,7 @@ type 'm ctx = unit
let thunk_expr (type m) (e : m A.expr boxed) : m A.expr boxed =
let dummy_var = Var.make "_" in
let pos = Expr.pos e in
let arg_t = Marked.mark pos (TLit TUnit) in
let arg_t = Mark.add pos (TLit TUnit) in
Expr.make_abs [| dummy_var |] e [arg_t] pos
let translate_var : 'm D.expr Var.t -> 'm A.expr Var.t = Var.translate
@ -57,8 +57,8 @@ let rec translate_default
exceptions
and translate_expr (ctx : 'm ctx) (e : 'm D.expr) : 'm A.expr boxed =
let m = Marked.get_mark e in
match Marked.unmark e with
let m = Mark.get e in
match Mark.remove e with
| EEmptyError -> Expr.eraise EmptyError m
| EErrorOnEmpty arg ->
Expr.ecatch (translate_expr ctx arg) EmptyError
@ -68,16 +68,16 @@ and translate_expr (ctx : 'm ctx) (e : 'm D.expr) : 'm A.expr boxed =
(* FIXME: bad place to rely on a global flag *)
Expr.ecatch (translate_expr ctx exn) EmptyError
(Expr.eifthenelse (translate_expr ctx just) (translate_expr ctx cons)
(Expr.eraise EmptyError (Marked.get_mark e))
(Marked.get_mark e))
(Marked.get_mark e)
(Expr.eraise EmptyError (Mark.get e))
(Mark.get e))
(Mark.get e)
| EDefault { excepts; just; cons } ->
translate_default ctx excepts just cons (Marked.get_mark e)
translate_default ctx excepts just cons (Mark.get e)
| EOp { op; tys } -> Expr.eop (Operator.translate op) tys m
| ( ELit _ | EApp _ | EArray _ | EVar _ | EAbs _ | EIfThenElse _ | ETuple _
| ETupleAccess _ | EInj _ | EAssert _ | EStruct _ | EStructAccess _
| EMatch _ ) as e ->
Expr.map ~f:(translate_expr ctx) (Marked.mark m e)
Expr.map ~f:(translate_expr ctx) (Mark.add m e)
| _ -> .
let rec translate_scope_lets

25
compiler/lcalc/compile_without_exceptions.ml
View File

@ -45,14 +45,13 @@ open Shared_ast
not sufficient as the typing inference need at least input and output types.
Those a generated using the [trans_typ_keep] function, that build [TOption]s
where needed. *)
let trans_typ_to_any (tau : typ) : typ = Marked.same_mark_as TAny tau
let trans_typ_to_any (tau : typ) : typ = Mark.copy tau TAny
let rec trans_typ_keep (tau : typ) : typ =
let m = Marked.get_mark tau in
(Fun.flip Marked.same_mark_as)
tau
let m = Mark.get tau in
Mark.copy tau
begin
match Marked.unmark tau with
match Mark.remove tau with
| TLit l -> TLit l
| TTuple ts -> TTuple (List.map trans_typ_keep ts)
| TStruct s -> TStruct s
@ -64,13 +63,13 @@ let rec trans_typ_keep (tau : typ) : typ =
| TAny -> TAny
| TArray ts ->
TArray (TOption (trans_typ_keep ts), m) (* catala is not polymorphic *)
| TArrow ([(TLit TUnit, _)], t2) -> Marked.unmark (trans_typ_keep t2)
| TArrow ([(TLit TUnit, _)], t2) -> Mark.remove (trans_typ_keep t2)
| TArrow (t1, t2) ->
TArrow (List.map trans_typ_keep t1, (TOption (trans_typ_keep t2), m))
end
let trans_typ_keep (tau : typ) : typ =
Marked.same_mark_as (TOption (trans_typ_keep tau)) tau
Mark.copy tau (TOption (trans_typ_keep tau))
let trans_op : dcalc Op.t -> lcalc Op.t = Operator.translate
@ -100,11 +99,11 @@ let trans_var (ctx : 'm ctx) (x : 'm D.expr Var.t) : 'm Ast.expr Var.t =
generated code. *)
let rec trans (ctx : typed ctx) (e : typed D.expr) :
(lcalc, typed mark) boxed_gexpr =
let m = Marked.get_mark e in
let m = Mark.get e in
let mark = m in
let pos = Expr.pos e in
(* Cli.debug_format "%a" (Print.expr ~debug:true ()) e; *)
match Marked.unmark e with
match Mark.remove e with
| EVar x ->
if (Var.Map.find x ctx.ctx_vars).info_pure then
Ast.OptionMonad.return (Expr.evar (trans_var ctx x) m) ~mark
@ -355,7 +354,7 @@ let rec trans (ctx : typed ctx) (e : typed D.expr) :
| EMatch { name; e; cases } ->
let cases =
EnumConstructor.MapLabels.map cases ~f:(fun case ->
match Marked.unmark case with
match Mark.remove case with
| EAbs { binder; tys } ->
let vars, body = Bindlib.unmbind binder in
let ctx' =
@ -592,7 +591,7 @@ let rec trans_scope_let (ctx : typed ctx) (s : typed D.expr scope_let) =
| DestructuringInputStruct -> (
(* note for future: we keep this useless match for distinguishing
further optimization while building the terms. *)
match Marked.unmark scope_let_typ with
match Mark.remove scope_let_typ with
| TArrow ([(TLit TUnit, _)], _) ->
{ info_pure = false; is_scope = false; var = next_var' }
| _ -> { info_pure = false; is_scope = false; var = next_var' })
@ -627,14 +626,14 @@ and trans_scope_body_expr ctx s :
match s with
| Result e -> begin
(* invariant : result is always in the form of a record. *)
match Marked.unmark e with
match Mark.remove e with
| EStruct { name; fields } ->
Bindlib.box_apply
(fun e -> Result e)
(Expr.Box.lift
@@ Expr.estruct name
(StructField.Map.map (trans ctx) fields)
(Marked.get_mark e))
(Mark.get e))
| _ -> assert false
end
| ScopeLet s ->

26
compiler/lcalc/to_ocaml.ml
View File

@ -35,8 +35,8 @@ let find_enum (en : EnumName.t) (ctx : decl_ctx) : typ EnumConstructor.Map.t =
"Internal Error: Enumeration %s was not found in the current environment."
en_name
let format_lit (fmt : Format.formatter) (l : lit Marked.pos) : unit =
match Marked.unmark l with
let format_lit (fmt : Format.formatter) (l : lit Mark.pos) : unit =
match Mark.remove l with
| LBool b -> Print.lit fmt (LBool b)
| LInt i ->
Format.fprintf fmt "integer_of_string@ \"%s\"" (Runtime.integer_to_string i)
@ -132,7 +132,7 @@ let format_enum_cons_name (fmt : Format.formatter) (v : EnumConstructor.t) :
(String.to_ascii (Format.asprintf "%a" EnumConstructor.format_t v)))
let rec typ_embedding_name (fmt : Format.formatter) (ty : typ) : unit =
match Marked.unmark ty with
match Mark.remove ty with
| TLit TUnit -> Format.fprintf fmt "embed_unit"
| TLit TBool -> Format.fprintf fmt "embed_bool"
| TLit TInt -> Format.fprintf fmt "embed_integer"
@ -146,14 +146,14 @@ let rec typ_embedding_name (fmt : Format.formatter) (ty : typ) : unit =
| _ -> Format.fprintf fmt "unembeddable"
let typ_needs_parens (e : typ) : bool =
match Marked.unmark e with TArrow _ | TArray _ -> true | _ -> false
match Mark.remove e with TArrow _ | TArray _ -> true | _ -> false
let rec format_typ (fmt : Format.formatter) (typ : typ) : unit =
let format_typ_with_parens (fmt : Format.formatter) (t : typ) =
if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t
else Format.fprintf fmt "%a" format_typ t
in
match Marked.unmark typ with
match Mark.remove typ with
| TLit l -> Format.fprintf fmt "%a" Print.tlit l
| TTuple ts ->
Format.fprintf fmt "@[<hov 2>(%a)@]"
@ -193,17 +193,17 @@ let format_var (fmt : Format.formatter) (v : 'm Var.t) : unit =
else Format.fprintf fmt "%s_" lowercase_name
let needs_parens (e : 'm expr) : bool =
match Marked.unmark e with
match Mark.remove e with
| EApp { f = EAbs _, _; _ }
| ELit (LBool _ | LUnit)
| EVar _ | ETuple _ | EOp _ ->
false
| _ -> true
let format_exception (fmt : Format.formatter) (exc : except Marked.pos) : unit =
match Marked.unmark exc with
let format_exception (fmt : Format.formatter) (exc : except Mark.pos) : unit =
match Mark.remove exc with
| ConflictError ->
let pos = Marked.get_mark exc in
let pos = Mark.get exc in
Format.fprintf fmt
"(ConflictError@ @[<hov 2>{filename = \"%s\";@ start_line=%d;@ \
start_column=%d;@ end_line=%d; end_column=%d;@ law_headings=%a}@])"
@ -213,7 +213,7 @@ let format_exception (fmt : Format.formatter) (exc : except Marked.pos) : unit =
| EmptyError -> Format.fprintf fmt "EmptyError"
| Crash -> Format.fprintf fmt "Crash"
| NoValueProvided ->
let pos = Marked.get_mark exc in
let pos = Mark.get exc in
Format.fprintf fmt
"(NoValueProvided@ @[<hov 2>{filename = \"%s\";@ start_line=%d;@ \
start_column=%d;@ end_line=%d; end_column=%d;@ law_headings=%a}@])"
@ -228,7 +228,7 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
if needs_parens e then Format.fprintf fmt "(%a)" format_expr e
else Format.fprintf fmt "%a" format_expr e
in
match Marked.unmark e with
match Mark.remove e with
| EVar v -> Format.fprintf fmt "%a" format_var v
| ETuple es ->
Format.fprintf fmt "@[<hov 2>(%a)@]"
@ -274,7 +274,7 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
Format.fprintf fmt "@[<hov 2>%a.%a %a@]" format_to_module_name
(`Ename name) format_enum_cons_name c
(fun fmt e ->
match Marked.unmark e with
match Mark.remove e with
| EAbs { binder; _ } ->
let xs, body = Bindlib.unmbind binder in
Format.fprintf fmt "%a ->@ %a"
@ -286,7 +286,7 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) :
(* should not happen *))
e))
(EnumConstructor.Map.bindings cases)
| ELit l -> Format.fprintf fmt "%a" format_lit (Marked.mark (Expr.pos e) l)
| ELit l -> Format.fprintf fmt "%a" format_lit (Mark.add (Expr.pos e) l)
| EApp { f = EAbs { binder; tys }, _; args } ->
let xs, body = Bindlib.unmbind binder in
let xs_tau = List.map2 (fun x tau -> x, tau) (Array.to_list xs) tys in

2
compiler/lcalc/to_ocaml.mli
View File

@ -33,7 +33,7 @@ val format_struct_field_name :
val format_to_module_name :
Format.formatter -> [< `Ename of EnumName.t | `Sname of StructName.t ] -> unit
(* * val format_lit : Format.formatter -> lit Marked.pos -> unit * val
(* * val format_lit : Format.formatter -> lit Mark.pos -> unit * val
format_uid_list : Format.formatter -> Uid.MarkedString.info list -> unit *)
val format_var : Format.formatter -> 'm Var.t -> unit

25
compiler/literate/html.ml
View File

@ -99,11 +99,10 @@ let wrap_html
(** Performs syntax highlighting on a piece of code by using Pygments and the
special Catala lexer. *)
let pygmentize_code (c : string Marked.pos) (lang : C.backend_lang) : string =
C.debug_print "Pygmenting the code chunk %s"
(Pos.to_string (Marked.get_mark c));
let pygmentize_code (c : string Mark.pos) (lang : C.backend_lang) : string =
C.debug_print "Pygmenting the code chunk %s" (Pos.to_string (Mark.get c));
let output =
File.with_temp_file "catala_html_pygments" "in" ~contents:(Marked.unmark c)
File.with_temp_file "catala_html_pygments" "in" ~contents:(Mark.remove c)
@@ fun temp_file_in ->
call_pygmentize ~lang
[
@ -111,9 +110,9 @@ let pygmentize_code (c : string Marked.pos) (lang : C.backend_lang) : string =
"html";
"-O";
"anchorlinenos=True,lineanchors="
^ String.to_ascii (Pos.get_file (Marked.get_mark c))
^ String.to_ascii (Pos.get_file (Mark.get c))
^ ",linenos=table,linenostart="
^ string_of_int (Pos.get_start_line (Marked.get_mark c));
^ string_of_int (Pos.get_start_line (Mark.get c));
temp_file_in;
]
in
@ -141,9 +140,9 @@ let rec law_structure_to_html
let t = pre_html t in
if t = "" then () else Format.fprintf fmt "<div class='law-text'>%s</div>" t
| A.CodeBlock (_, c, metadata) when not print_only_law ->
let start_line = Pos.get_start_line (Marked.get_mark c) - 1 in
let filename = Pos.get_file (Marked.get_mark c) in
let block_content = Marked.unmark c in
let start_line = Pos.get_start_line (Mark.get c) - 1 in
let filename = Pos.get_file (Mark.get c) in
let block_content = Mark.remove c in
check_exceeding_lines start_line filename block_content;
Format.fprintf fmt
"<div class='code-wrapper%s catala-code'>\n\
@ -151,9 +150,9 @@ let rec law_structure_to_html
%s\n\
</div>"
(if metadata then " code-metadata" else "")
(Pos.get_file (Marked.get_mark c))
(Pos.get_file (Mark.get c))
(pygmentize_code
(Marked.same_mark_as ("```catala\n" ^ Marked.unmark c ^ "```") c)
(Mark.copy c ("```catala\n" ^ Mark.remove c ^ "```"))
language)
| A.CodeBlock _ -> ()
| A.LawHeading (heading, children) ->
@ -165,7 +164,7 @@ let rec law_structure_to_html
practicable. *)
h_number = 2
in
let h_name = Marked.unmark heading.law_heading_name in
let h_name = Mark.remove heading.law_heading_name in
let complete_headings = parents_headings @ [h_name] in
let id = complete_headings |> String.concat "-" |> sanitize_html_href in
let fmt_details_open fmt () =
@ -213,7 +212,7 @@ let rec fmt_toc
(fun fmt item ->
match item with
| A.LawHeading (heading, childs) ->
let h_name = Marked.unmark heading.law_heading_name in
let h_name = Mark.remove heading.law_heading_name in
let complete_headings = parents_headings @ [h_name] in
let id =
complete_headings |> String.concat "-" |> sanitize_html_href

18
compiler/literate/latex.ml
View File

@ -31,8 +31,8 @@ let lines_of_code = ref 0
let update_lines_of_code c =
lines_of_code :=
!lines_of_code
+ Pos.get_end_line (Marked.get_mark c)
- Pos.get_start_line (Marked.get_mark c)
+ Pos.get_end_line (Mark.get c)
- Pos.get_start_line (Mark.get c)
- 1
(** Espaces various LaTeX-sensitive characters *)
@ -225,7 +225,7 @@ let rec law_structure_to_latex
| 6 -> "subsubsubsubsubsubsection"
| 7 -> "paragraph"
| _ -> "subparagraph")
(pre_latexify (Marked.unmark heading.law_heading_name));
(pre_latexify (Mark.remove heading.law_heading_name));
Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(law_structure_to_latex language print_only_law)
@ -245,9 +245,9 @@ let rec law_structure_to_latex
| A.LawInclude (A.CatalaFile _ | A.LegislativeText _) -> ()
| A.LawText t -> Format.fprintf fmt "%s" (pre_latexify t)
| A.CodeBlock (_, c, false) when not print_only_law ->
let start_line = Pos.get_start_line (Marked.get_mark c) - 1 in
let filename = Pos.get_file (Marked.get_mark c) in
let block_content = Marked.unmark c in
let start_line = Pos.get_start_line (Mark.get c) - 1 in
let filename = Pos.get_file (Mark.get c) in
let block_content = Mark.remove c in
check_exceeding_lines start_line filename block_content;
update_lines_of_code c;
code_block ~meta:false language fmt c
@ -258,9 +258,9 @@ let rec law_structure_to_latex
| En -> "Metadata"
| Pl -> "Metadane"
in
let start_line = Pos.get_start_line (Marked.get_mark c) + 1 in
let filename = Pos.get_file (Marked.get_mark c) in
let block_content = Marked.unmark c in
let start_line = Pos.get_start_line (Mark.get c) + 1 in
let filename = Pos.get_file (Mark.get c) in
let block_content = Mark.remove c in
check_exceeding_lines start_line filename block_content;
update_lines_of_code c;
Format.fprintf fmt

16
compiler/plugins/api_web.ml
View File

@ -64,7 +64,7 @@ module To_jsoo = struct
if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t
else Format.fprintf fmt "%a" format_typ t
in
match Marked.unmark typ with
match Mark.remove typ with
| TLit l -> Format.fprintf fmt "%a" format_tlit l
| TStruct s -> Format.fprintf fmt "%a Js.t" format_struct_name s
| TTuple _ ->
@ -85,7 +85,7 @@ module To_jsoo = struct
t1 format_typ_with_parens t2
let rec format_typ_to_jsoo fmt typ =
match Marked.unmark typ with
match Mark.remove typ with
| TLit TBool -> Format.fprintf fmt "Js.bool"
| TLit TInt -> Format.fprintf fmt "integer_to_int"
| TLit TRat -> Format.fprintf fmt "Js.number_of_float %@%@ decimal_to_float"
@ -101,7 +101,7 @@ module To_jsoo = struct
| _ -> Format.fprintf fmt ""
let rec format_typ_of_jsoo fmt typ =
match Marked.unmark typ with
match Mark.remove typ with
| TLit TBool -> Format.fprintf fmt "Js.to_bool"
| TLit TInt -> Format.fprintf fmt "integer_of_int"
| TLit TRat -> Format.fprintf fmt "decimal_of_float %@%@ Js.float_of_number"
@ -140,7 +140,7 @@ module To_jsoo = struct
(fmt : Format.formatter)
(ctx : decl_ctx) : unit =
let format_prop_or_meth fmt (struct_field_type : typ) =
match Marked.unmark struct_field_type with
match Mark.remove struct_field_type with
| TArrow _ -> Format.fprintf fmt "Js.meth"
| _ -> Format.fprintf fmt "Js.readonly_prop"
in
@ -154,7 +154,7 @@ module To_jsoo = struct
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (struct_field, struct_field_type) ->
match Marked.unmark struct_field_type with
match Mark.remove struct_field_type with
| TArrow (t1, t2) ->
let args_names =
ListLabels.mapi t1 ~f:(fun i _ ->
@ -185,7 +185,7 @@ module To_jsoo = struct
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ";@\n")
(fun fmt (struct_field, struct_field_type) ->
match Marked.unmark struct_field_type with
match Mark.remove struct_field_type with
| TArrow _ ->
Format.fprintf fmt
"%a = failwith \"The function '%a' translation isn't yet \
@ -246,7 +246,7 @@ module To_jsoo = struct
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (cname, typ) ->
match Marked.unmark typ with
match Mark.remove typ with
| TTuple _ ->
Cli.error_print
"Tuples aren't supported yet in the conversion to JS"
@ -271,7 +271,7 @@ module To_jsoo = struct
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(fun fmt (cname, typ) ->
match Marked.unmark typ with
match Mark.remove typ with
| TTuple _ ->
Cli.error_print
"Tuples aren't yet supported in the conversion to JS..."

8
compiler/plugins/json_schema.ml
View File

@ -61,7 +61,7 @@ module To_json = struct
()
let rec fmt_type fmt (typ : typ) =
match Marked.unmark typ with
match Mark.remove typ with
| TLit tlit -> fmt_tlit fmt tlit
| TStruct sname ->
Format.fprintf fmt "\"$ref\": \"#/definitions/%a\"" format_struct_name
@ -95,7 +95,7 @@ module To_json = struct
(fmt : Format.formatter)
((_scope_name, scope_body) : ScopeName.t * 'e scope_body) =
let get_name t =
match Marked.unmark t with
match Mark.remove t with
| TStruct sname -> Format.asprintf "%a" format_struct_name sname
| TEnum ename -> Format.asprintf "%a" format_enum_name ename
| _ -> failwith "unreachable: only structs and enums are collected."
@ -103,7 +103,7 @@ module To_json = struct
let rec collect_required_type_defs_from_scope_input
(input_struct : StructName.t) : typ list =
let rec collect (acc : typ list) (t : typ) : typ list =
match Marked.unmark t with
match Mark.remove t with
| TStruct s ->
(* Scope's input is a struct. *)
(t :: acc) @ collect_required_type_defs_from_scope_input s
@ -169,7 +169,7 @@ module To_json = struct
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@\n")
(fun fmt typ ->
match Marked.unmark typ with
match Mark.remove typ with
| TStruct sname ->
Format.fprintf fmt
"@[<hov 2>\"%a\": {@\n\

2
compiler/plugins/lazy_interp.ml
View File

@ -232,7 +232,7 @@ let interpret_program
log "=====================";
log "%a" (Print.expr ~debug:true ()) e;
log "=====================";
let m = Marked.get_mark e in
let m = Mark.get e in
let application_arg =
Expr.estruct scope_arg_struct
(StructField.Map.map

16
compiler/scalc/ast.ml
View File

@ -29,7 +29,7 @@ type operator =
< overloaded : no ; monomorphic : yes ; polymorphic : yes ; resolved : yes >
Shared_ast.operator
type expr = naked_expr Marked.pos
type expr = naked_expr Mark.pos
and naked_expr =
| EVar : VarName.t -> naked_expr
@ -43,9 +43,9 @@ and naked_expr =
| EOp : operator -> naked_expr
type stmt =
| SInnerFuncDef of VarName.t Marked.pos * func
| SLocalDecl of VarName.t Marked.pos * typ
| SLocalDef of VarName.t Marked.pos * expr
| SInnerFuncDef of VarName.t Mark.pos * func
| SLocalDecl of VarName.t Mark.pos * typ
| SLocalDef of VarName.t Mark.pos * expr
| STryExcept of block * except * block
| SRaise of except
| SIfThenElse of expr * block * block
@ -58,12 +58,8 @@ type stmt =
| SReturn of naked_expr
| SAssert of naked_expr
and block = stmt Marked.pos list
and func = {
func_params : (VarName.t Marked.pos * typ) list;
func_body : block;
}
and block = stmt Mark.pos list
and func = { func_params : (VarName.t Mark.pos * typ) list; func_body : block }
type scope_body = {
scope_body_name : ScopeName.t;

47
compiler/scalc/from_lcalc.ml
View File

@ -31,7 +31,7 @@ type 'm ctxt = {
(* Expressions can spill out side effect, hence this function also returns a
list of statements to be prepended before the expression is evaluated *)
let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
match Marked.unmark expr with
match Mark.remove expr with
| EVar v ->
let local_var =
try A.EVar (Var.Map.find v ctxt.var_dict)
@ -97,7 +97,7 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
(match ctxt.inside_definition_of with
| None -> ctxt.context_name
| Some v ->
let v = Marked.unmark (A.VarName.get_info v) in
let v = Mark.remove (A.VarName.get_info v) in
let tmp_rex = Re.Pcre.regexp "^temp_" in
if Re.Pcre.pmatch ~rex:tmp_rex v then v else "temp_" ^ v),
Expr.pos expr )
@ -106,7 +106,7 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
{
ctxt with
inside_definition_of = Some tmp_var;
context_name = Marked.unmark (A.VarName.get_info tmp_var);
context_name = Mark.remove (A.VarName.get_info tmp_var);
}
in
let tmp_stmts = translate_statements ctxt expr in
@ -116,11 +116,11 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
(A.EVar tmp_var, Expr.pos expr) )
and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
match Marked.unmark block_expr with
match Mark.remove block_expr with
| EAssert e ->
(* Assertions are always encapsulated in a unit-typed let binding *)
let e_stmts, new_e = translate_expr ctxt e in
e_stmts @ [A.SAssert (Marked.unmark new_e), Expr.pos block_expr]
e_stmts @ [A.SAssert (Mark.remove new_e), Expr.pos block_expr]
| EApp { f = EAbs { binder; tys }, binder_mark; args } ->
(* This defines multiple local variables at the time *)
let binder_pos = Expr.mark_pos binder_mark in
@ -157,9 +157,8 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
let ctxt =
{
ctxt with
inside_definition_of = Some (Marked.unmark x);
context_name =
Marked.unmark (A.VarName.get_info (Marked.unmark x));
inside_definition_of = Some (Mark.remove x);
context_name = Mark.remove (A.VarName.get_info (Mark.remove x));
}
in
let arg_stmts, new_arg = translate_expr ctxt arg in
@ -209,7 +208,7 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
let new_cases =
EnumConstructor.Map.fold
(fun _ arg new_args ->
match Marked.unmark arg with
match Mark.remove arg with
| EAbs { binder; _ } ->
let vars, body = Bindlib.unmbind binder in
assert (Array.length vars = 1);
@ -264,8 +263,8 @@ and translate_statements (ctxt : 'm ctxt) (block_expr : 'm L.expr) : A.block =
| _ ->
[
( (match ctxt.inside_definition_of with
| None -> A.SReturn (Marked.unmark new_e)
| Some x -> A.SLocalDef (Marked.same_mark_as x new_e, new_e)),
| None -> A.SReturn (Mark.remove new_e)
| Some x -> A.SLocalDef (Mark.copy new_e x, new_e)),
Expr.pos block_expr );
])
@ -284,11 +283,11 @@ let rec translate_scope_body_expr
func_dict;
var_dict;
inside_definition_of = None;
context_name = Marked.unmark (ScopeName.get_info scope_name);
context_name = Mark.remove (ScopeName.get_info scope_name);
}
e
in
block @ [A.SReturn (Marked.unmark new_e), Marked.get_mark new_e]
block @ [A.SReturn (Mark.remove new_e), Mark.get new_e]
| ScopeLet scope_let ->
let let_var, scope_let_next = Bindlib.unbind scope_let.scope_let_next in
let let_var_id =
@ -303,7 +302,7 @@ let rec translate_scope_body_expr
func_dict;
var_dict;
inside_definition_of = Some let_var_id;
context_name = Marked.unmark (ScopeName.get_info scope_name);
context_name = Mark.remove (ScopeName.get_info scope_name);
}
scope_let.scope_let_expr
| _ ->
@ -314,7 +313,7 @@ let rec translate_scope_body_expr
func_dict;
var_dict;
inside_definition_of = Some let_var_id;
context_name = Marked.unmark (ScopeName.get_info scope_name);
context_name = Mark.remove (ScopeName.get_info scope_name);
}
scope_let.scope_let_expr
in
@ -338,7 +337,7 @@ let translate_program (p : 'm L.program) : A.program =
let scope_input_var, scope_body_expr =
Bindlib.unbind body.scope_body_expr
in
let input_pos = Marked.get_mark (ScopeName.get_info name) in
let input_pos = Mark.get (ScopeName.get_info name) in
let scope_input_var_id =
A.VarName.fresh (Bindlib.name_of scope_input_var, input_pos)
in
@ -375,7 +374,7 @@ let translate_program (p : 'm L.program) : A.program =
let args_id =
List.map2
(fun v ty ->
let pos = Marked.get_mark ty in
let pos = Mark.get ty in
(A.VarName.fresh (Bindlib.name_of v, pos), pos), ty)
args abs.tys
in
@ -389,13 +388,13 @@ let translate_program (p : 'm L.program) : A.program =
(fun map arg ((id, _), _) -> Var.Map.add arg id map)
var_dict args args_id;
inside_definition_of = None;
context_name = Marked.unmark (TopdefName.get_info name);
context_name = Mark.remove (TopdefName.get_info name);
}
in
translate_expr ctxt expr
in
let body_block =
block @ [A.SReturn (Marked.unmark expr), Marked.get_mark expr]
block @ [A.SReturn (Mark.remove expr), Mark.get expr]
in
( Var.Map.add var func_id func_dict,
var_dict,
@ -415,7 +414,7 @@ let translate_program (p : 'm L.program) : A.program =
decl_ctx = p.decl_ctx;
var_dict;
inside_definition_of = None;
context_name = Marked.unmark (TopdefName.get_info name);
context_name = Mark.remove (TopdefName.get_info name);
}
in
translate_expr ctxt expr
@ -426,7 +425,7 @@ let translate_program (p : 'm L.program) : A.program =
match block with
| [] -> A.SVar { var = var_id; expr } :: rev_items
| block ->
let pos = Marked.get_mark expr in
let pos = Mark.get expr in
let func_id =
A.FuncName.fresh (Bindlib.name_of var ^ "_aux", pos)
in
@ -440,11 +439,7 @@ let translate_program (p : 'm L.program) : A.program =
{
A.func_params = [];
A.func_body =
block
@ [
( A.SReturn (Marked.unmark expr),
Marked.get_mark expr );
];
block @ [A.SReturn (Mark.remove expr), Mark.get expr];
};
}
:: rev_items

20
compiler/scalc/print.ml
View File

@ -39,7 +39,7 @@ let rec format_expr
Print.punctuation ")"
else Format.fprintf fmt "%a" format_expr e
in
match Marked.unmark e with
match Mark.remove e with
| EVar v -> Format.fprintf fmt "%a" format_var_name v
| EFunc v -> Format.fprintf fmt "%a" format_func_name v
| EStruct (es, s) ->
@ -91,12 +91,12 @@ let rec format_statement
(decl_ctx : decl_ctx)
?(debug : bool = false)
(fmt : Format.formatter)
(stmt : stmt Marked.pos) : unit =
(stmt : stmt Mark.pos) : unit =
if debug then () else ();
match Marked.unmark stmt with
match Mark.remove stmt with
| SInnerFuncDef (name, func) ->
Format.fprintf fmt "@[<hov 2>%a@ %a@ %a@ %a@]@\n@[<v 2> %a@]" Print.keyword
"let" format_var_name (Marked.unmark name)
"let" format_var_name (Mark.remove name)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
(fun fmt ((name, _), typ) ->
@ -108,11 +108,11 @@ let rec format_statement
func.func_body
| SLocalDecl (name, typ) ->
Format.fprintf fmt "@[<hov 2>%a %a %a@ %a@]" Print.keyword "decl"
format_var_name (Marked.unmark name) Print.punctuation ":"
format_var_name (Mark.remove name) Print.punctuation ":"
(Print.typ decl_ctx) typ
| SLocalDef (name, naked_expr) ->
Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" format_var_name
(Marked.unmark name) Print.punctuation "="
Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" format_var_name (Mark.remove name)
Print.punctuation "="
(format_expr decl_ctx ~debug)
naked_expr
| STryExcept (b_try, except, b_with) ->
@ -137,11 +137,11 @@ let rec format_statement
| SReturn ret ->
Format.fprintf fmt "@[<hov 2>%a %a@]" Print.keyword "return"
(format_expr decl_ctx ~debug)
(ret, Marked.get_mark stmt)
(ret, Mark.get stmt)
| SAssert naked_expr ->
Format.fprintf fmt "@[<hov 2>%a %a@]" Print.keyword "assert"
(format_expr decl_ctx ~debug)
(naked_expr, Marked.get_mark stmt)
(naked_expr, Mark.get stmt)
| SSwitch (e_switch, enum, arms) ->
Format.fprintf fmt "@[<v 0>%a @[<hov 2>%a@]%a@]%a" Print.keyword "switch"
(format_expr decl_ctx ~debug)
@ -186,7 +186,7 @@ let format_item decl_ctx ?debug ppf def =
format_func_name ppf var;
Format.pp_print_list
(fun ppf (arg, ty) ->
Format.fprintf ppf "@ (%a: %a)" format_var_name (Marked.unmark arg)
Format.fprintf ppf "@ (%a: %a)" format_var_name (Mark.remove arg)
(Print.typ decl_ctx) ty)
ppf func.func_params;
Print.punctuation ppf " =";

50
compiler/scalc/to_python.ml
View File

@ -22,8 +22,8 @@ module Runtime = Runtime_ocaml.Runtime
module D = Dcalc.Ast
module L = Lcalc.Ast
let format_lit (fmt : Format.formatter) (l : lit Marked.pos) : unit =
match Marked.unmark l with
let format_lit (fmt : Format.formatter) (l : lit Mark.pos) : unit =
match Mark.remove l with
| LBool true -> Format.pp_print_string fmt "True"
| LBool false -> Format.pp_print_string fmt "False"
| LInt i ->
@ -49,8 +49,8 @@ let format_log_entry (fmt : Format.formatter) (entry : log_entry) : unit =
| EndCall -> Format.fprintf fmt "%s" "← "
| PosRecordIfTrueBool -> Format.pp_print_string fmt "☛ "
let format_op (fmt : Format.formatter) (op : operator Marked.pos) : unit =
match Marked.unmark op with
let format_op (fmt : Format.formatter) (op : operator Mark.pos) : unit =
match Mark.remove op with
| Log (entry, infos) -> assert false
| Minus_int | Minus_rat | Minus_mon | Minus_dur ->
Format.pp_print_string fmt "-"
@ -157,7 +157,7 @@ let format_enum_cons_name (fmt : Format.formatter) (v : EnumConstructor.t) :
(String.to_ascii (Format.asprintf "%a" EnumConstructor.format_t v)))
let typ_needs_parens (e : typ) : bool =
match Marked.unmark e with TArrow _ | TArray _ -> true | _ -> false
match Mark.remove e with TArrow _ | TArray _ -> true | _ -> false
let rec format_typ (fmt : Format.formatter) (typ : typ) : unit =
let format_typ = format_typ in
@ -165,7 +165,7 @@ let rec format_typ (fmt : Format.formatter) (typ : typ) : unit =
if typ_needs_parens t then Format.fprintf fmt "(%a)" format_typ t
else Format.fprintf fmt "%a" format_typ t
in
match Marked.unmark typ with
match Mark.remove typ with
| TLit TUnit -> Format.fprintf fmt "Unit"
| TLit TMoney -> Format.fprintf fmt "Money"
| TLit TInt -> Format.fprintf fmt "Integer"
@ -213,7 +213,7 @@ module IntMap = Map.Make (Int)
let string_counter_map : int IntMap.t StringMap.t ref = ref StringMap.empty
let format_var (fmt : Format.formatter) (v : VarName.t) : unit =
let v_str = Marked.unmark (VarName.get_info v) in
let v_str = Mark.remove (VarName.get_info v) in
let hash = VarName.hash v in
let local_id =
match StringMap.find_opt v_str !string_counter_map with
@ -244,20 +244,20 @@ let format_var (fmt : Format.formatter) (v : VarName.t) : unit =
else Format.fprintf fmt "%a_%d" format_name_cleaned v_str local_id
let format_func_name (fmt : Format.formatter) (v : FuncName.t) : unit =
let v_str = Marked.unmark (FuncName.get_info v) in
let v_str = Mark.remove (FuncName.get_info v) in
format_name_cleaned fmt v_str
let format_var_name (fmt : Format.formatter) (v : VarName.t) : unit =
Format.fprintf fmt "%a_%s" VarName.format_t v (string_of_int (VarName.hash v))
let needs_parens (e : expr) : bool =
match Marked.unmark e with
match Mark.remove e with
| ELit (LBool _ | LUnit) | EVar _ | EOp _ -> false
| _ -> true
let format_exception (fmt : Format.formatter) (exc : except Marked.pos) : unit =
let pos = Marked.get_mark exc in
match Marked.unmark exc with
let format_exception (fmt : Format.formatter) (exc : except Mark.pos) : unit =
let pos = Mark.get exc in
match Mark.remove exc with
| ConflictError ->
Format.fprintf fmt
"ConflictError(@[<hov 0>SourcePosition(@[<hov 0>filename=\"%s\",@ \
@ -279,7 +279,7 @@ let format_exception (fmt : Format.formatter) (exc : except Marked.pos) : unit =
let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
unit =
match Marked.unmark e with
match Mark.remove e with
| EVar v -> format_var fmt v
| EFunc f -> format_func_name fmt f
| EStruct (es, s) ->
@ -314,7 +314,7 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
(fun fmt e -> Format.fprintf fmt "%a" (format_expression ctx) e))
es
| ELit l -> Format.fprintf fmt "%a" format_lit (Marked.same_mark_as l e)
| ELit l -> Format.fprintf fmt "%a" format_lit (Mark.copy e l)
| EApp ((EOp ((Map | Filter) as op), _), [arg1; arg2]) ->
Format.fprintf fmt "%a(%a,@ %a)" format_op (op, Pos.no_pos)
(format_expression ctx) arg1 (format_expression ctx) arg2
@ -387,21 +387,21 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
let rec format_statement
(ctx : decl_ctx)
(fmt : Format.formatter)
(s : stmt Marked.pos) : unit =
match Marked.unmark s with
(s : stmt Mark.pos) : unit =
match Mark.remove s with
| SInnerFuncDef (name, { func_params; func_body }) ->
Format.fprintf fmt "@[<hov 4>def %a(%a):@\n%a@]" format_var
(Marked.unmark name)
(Mark.remove name)
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
(fun fmt (var, typ) ->
Format.fprintf fmt "%a:%a" format_var (Marked.unmark var) format_typ
Format.fprintf fmt "%a:%a" format_var (Mark.remove var) format_typ
typ))
func_params (format_block ctx) func_body
| SLocalDecl _ ->
assert false (* We don't need to declare variables in Python *)
| SLocalDef (v, e) ->
Format.fprintf fmt "@[<hov 4>%a = %a@]" format_var (Marked.unmark v)
Format.fprintf fmt "@[<hov 4>%a = %a@]" format_var (Mark.remove v)
(format_expression ctx) e
| STryExcept (try_b, except, catch_b) ->
Format.fprintf fmt "@[<hov 4>try:@\n%a@]@\n@[<hov 4>except %a:@\n%a@]"
@ -409,7 +409,7 @@ let rec format_statement
(format_block ctx) catch_b
| SRaise except ->
Format.fprintf fmt "@[<hov 4>raise %a@]" format_exception
(except, Marked.get_mark s)
(except, Mark.get s)
| SIfThenElse (cond, b1, b2) ->
Format.fprintf fmt "@[<hov 4>if %a:@\n%a@]@\n@[<hov 4>else:@\n%a@]"
(format_expression ctx) cond (format_block ctx) b1 (format_block ctx) b2
@ -447,16 +447,16 @@ let rec format_statement
cases
| SReturn e1 ->
Format.fprintf fmt "@[<hov 4>return %a@]" (format_expression ctx)
(e1, Marked.get_mark s)
(e1, Mark.get s)
| SAssert e1 ->
let pos = Marked.get_mark s in
let pos = Mark.get s in
Format.fprintf fmt
"@[<hov 4>if not (%a):@\n\
raise AssertionFailure(@[<hov 0>SourcePosition(@[<hov \
0>filename=\"%s\",@ start_line=%d,@ start_column=%d,@ end_line=%d,@ \
end_column=%d,@ law_headings=@[<hv>%a@])@])@]@]"
(format_expression ctx)
(e1, Marked.get_mark s)
(e1, Mark.get s)
(Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
(Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
(Pos.get_law_info pos)
@ -466,7 +466,7 @@ and format_block (ctx : decl_ctx) (fmt : Format.formatter) (b : block) : unit =
~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
(format_statement ctx) fmt
(List.filter
(fun s -> match Marked.unmark s with SLocalDecl _ -> false | _ -> true)
(fun s -> match Mark.remove s with SLocalDecl _ -> false | _ -> true)
b)
let format_ctx
@ -625,7 +625,7 @@ let format_program
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
(fun fmt (var, typ) ->
Format.fprintf fmt "%a:%a" format_var (Marked.unmark var)
Format.fprintf fmt "%a:%a" format_var (Mark.remove var)
format_typ typ))
func_params (format_block p.decl_ctx) func_body))
p.code_items)

19
compiler/scopelang/ast.ml
View File

@ -19,9 +19,8 @@ open Shared_ast
type location = scopelang glocation
module LocationSet : Set.S with type elt = location Marked.pos =
Set.Make (struct
type t = location Marked.pos
module LocationSet : Set.S with type elt = location Mark.pos = Set.Make (struct
type t = location Mark.pos
let compare = Expr.compare_location
end)
@ -40,7 +39,7 @@ let rec locations_used (e : 'm expr) : LocationSet.t =
e LocationSet.empty
type 'm rule =
| Definition of location Marked.pos * typ * Desugared.Ast.io * 'm expr
| Definition of location Mark.pos * typ * Desugared.Ast.io * 'm expr
| Assertion of 'm expr
| Call of ScopeName.t * SubScopeName.t * 'm mark
@ -49,7 +48,7 @@ type 'm scope_decl = {
scope_sig : (typ * Desugared.Ast.io) ScopeVar.Map.t;
scope_decl_rules : 'm rule list;
scope_mark : 'm mark;
scope_options : Desugared.Ast.catala_option Marked.pos list;
scope_options : Desugared.Ast.catala_option Mark.pos list;
}
type 'm program = {
@ -63,12 +62,12 @@ let type_rule decl_ctx env = function
let expr' = Typing.expr ~leave_unresolved:false decl_ctx ~env ~typ expr in
Definition (loc, typ, io, Expr.unbox expr')
| Assertion expr ->
let typ = Marked.mark (Expr.pos expr) (TLit TBool) in
let typ = Mark.add (Expr.pos expr) (TLit TBool) in
let expr' = Typing.expr ~leave_unresolved:false decl_ctx ~env ~typ expr in
Assertion (Expr.unbox expr')
| Call (sc_name, ssc_name, m) ->
let pos = Expr.mark_pos m in
Call (sc_name, ssc_name, Typed { pos; ty = Marked.mark pos TAny })
Call (sc_name, ssc_name, Typed { pos; ty = Mark.add pos TAny })
let type_program (prg : 'm program) : typed program =
let typing_env =
@ -107,10 +106,8 @@ let type_program (prg : 'm program) : typed program =
scope_decl.scope_decl_rules
in
let scope_mark =
let pos =
Marked.get_mark (ScopeName.get_info scope_decl.scope_decl_name)
in
Typed { pos; ty = Marked.mark pos TAny }
let pos = Mark.get (ScopeName.get_info scope_decl.scope_decl_name) in
Typed { pos; ty = Mark.add pos TAny }
in
{ scope_decl with scope_decl_rules; scope_mark })
prg.program_scopes

6
compiler/scopelang/ast.mli
View File

@ -23,7 +23,7 @@ open Shared_ast
type location = scopelang glocation
module LocationSet : Set.S with type elt = location Marked.pos
module LocationSet : Set.S with type elt = location Mark.pos
(** {1 Abstract syntax tree} *)
@ -32,7 +32,7 @@ type 'm expr = (scopelang, 'm mark) gexpr
val locations_used : 'm expr -> LocationSet.t
type 'm rule =
| Definition of location Marked.pos * typ * Desugared.Ast.io * 'm expr
| Definition of location Mark.pos * typ * Desugared.Ast.io * 'm expr
| Assertion of 'm expr
| Call of ScopeName.t * SubScopeName.t * 'm mark
@ -41,7 +41,7 @@ type 'm scope_decl = {
scope_sig : (typ * Desugared.Ast.io) ScopeVar.Map.t;
scope_decl_rules : 'm rule list;
scope_mark : 'm mark;
scope_options : Desugared.Ast.catala_option Marked.pos list;
scope_options : Desugared.Ast.catala_option Mark.pos list;
}
type 'm program = {

24
compiler/scopelang/dependency.ml
View File

@ -96,8 +96,7 @@ let rule_used_defs = function
walking through all exprs again *)
expr_used_defs e
| Ast.Call (subscope, subindex, _) ->
VMap.singleton (Scope subscope)
(Marked.get_mark (SubScopeName.get_info subindex))
VMap.singleton (Scope subscope) (Mark.get (SubScopeName.get_info subindex))
let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t =
let g = SDependencies.empty in
@ -117,7 +116,7 @@ let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t =
let used_defs = expr_used_defs expr in
if VMap.mem (Topdef glo_name) used_defs then
Errors.raise_spanned_error
(Marked.get_mark (TopdefName.get_info glo_name))
(Mark.get (TopdefName.get_info glo_name))
"The Topdef %a has a definition that refers to itself, which is \
forbidden since Catala does not provide recursion"
TopdefName.format_t glo_name;
@ -135,7 +134,7 @@ let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t =
let used_defs = rule_used_defs rule in
if VMap.mem (Scope scope_name) used_defs then
Errors.raise_spanned_error
(Marked.get_mark (ScopeName.get_info scope.Ast.scope_decl_name))
(Mark.get (ScopeName.get_info scope.Ast.scope_decl_name))
"The scope %a is calling into itself as a subscope, which is \
forbidden since Catala does not provide recursion"
ScopeName.format_t scope.Ast.scope_decl_name;
@ -250,7 +249,7 @@ module TSCC = Graph.Components.Make (TDependencies)
(** Tarjan's stongly connected components algorithm, provided by OCamlGraph *)
let rec get_structs_or_enums_in_type (t : typ) : TVertexSet.t =
match Marked.unmark t with
match Mark.remove t with
| TStruct s -> TVertexSet.singleton (TVertex.Struct s)
| TEnum e -> TVertexSet.singleton (TVertex.Enum e)
| TArrow (t1, t2) ->
@ -280,14 +279,12 @@ let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t
TVertexSet.fold
(fun used g ->
if TVertex.equal used def then
Errors.raise_spanned_error (Marked.get_mark typ)
Errors.raise_spanned_error (Mark.get typ)
"The type %a is defined using itself, which is forbidden \
since Catala does not provide recursive types"
TVertex.format_t used
else
let edge =
TDependencies.E.create used (Marked.get_mark typ) def
in
let edge = TDependencies.E.create used (Mark.get typ) def in
TDependencies.add_edge_e g edge)
used g)
fields g)
@ -304,14 +301,12 @@ let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t
TVertexSet.fold
(fun used g ->
if TVertex.equal used def then
Errors.raise_spanned_error (Marked.get_mark typ)
Errors.raise_spanned_error (Mark.get typ)
"The type %a is defined using itself, which is forbidden \
since Catala does not provide recursive types"
TVertex.format_t used
else
let edge =
TDependencies.E.create used (Marked.get_mark typ) def
in
let edge = TDependencies.E.create used (Mark.get typ) def in
TDependencies.add_edge_e g edge)
used g)
cases g)
@ -340,8 +335,7 @@ let check_type_cycles (structs : struct_ctx) (enums : enum_ctx) : TVertex.t list
in
let succ_str = Format.asprintf "%a" TVertex.format_t succ in
[
( Some ("Cycle type " ^ var_str ^ ", declared:"),
Marked.get_mark var_info );
Some ("Cycle type " ^ var_str ^ ", declared:"), Mark.get var_info;
( Some
("Used here in the definition of another cycle type "
^ succ_str

87
compiler/scopelang/from_desugared.ml
View File

@ -38,41 +38,36 @@ let tag_with_log_entry
(markings : Uid.MarkedString.info list) : untyped Ast.expr boxed =
if !Cli.trace_flag then
Expr.eapp
(Expr.eop (Log (l, markings)) [TAny, Expr.pos e] (Marked.get_mark e))
[e] (Marked.get_mark e)
(Expr.eop (Log (l, markings)) [TAny, Expr.pos e] (Mark.get e))
[e] (Mark.get e)
else e
let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) :
untyped Ast.expr boxed =
let m = Marked.get_mark e in
match Marked.unmark e with
let m = Mark.get e in
match Mark.remove e with
| ELocation (SubScopeVar (s_name, ss_name, s_var)) ->
(* When referring to a subscope variable in an expression, we are referring
to the output, hence we take the last state. *)
let new_s_var =
match ScopeVar.Map.find (Marked.unmark s_var) ctx.scope_var_mapping with
| WholeVar new_s_var -> Marked.same_mark_as new_s_var s_var
| States states ->
Marked.same_mark_as (snd (List.hd (List.rev states))) s_var
match ScopeVar.Map.find (Mark.remove s_var) ctx.scope_var_mapping with
| WholeVar new_s_var -> Mark.copy s_var new_s_var
| States states -> Mark.copy s_var (snd (List.hd (List.rev states)))
in
Expr.elocation (SubScopeVar (s_name, ss_name, new_s_var)) m
| ELocation (DesugaredScopeVar (s_var, None)) ->
Expr.elocation
(ScopelangScopeVar
(match
ScopeVar.Map.find (Marked.unmark s_var) ctx.scope_var_mapping
with
| WholeVar new_s_var -> Marked.same_mark_as new_s_var s_var
(match ScopeVar.Map.find (Mark.remove s_var) ctx.scope_var_mapping with
| WholeVar new_s_var -> Mark.copy s_var new_s_var
| States _ -> failwith "should not happen"))
m
| ELocation (DesugaredScopeVar (s_var, Some state)) ->
Expr.elocation
(ScopelangScopeVar
(match
ScopeVar.Map.find (Marked.unmark s_var) ctx.scope_var_mapping
with
(match ScopeVar.Map.find (Mark.remove s_var) ctx.scope_var_mapping with
| WholeVar _ -> failwith "should not happen"
| States states -> Marked.same_mark_as (List.assoc state states) s_var))
| States states -> Mark.copy s_var (List.assoc state states)))
m
| ELocation (ToplevelVar v) -> Expr.elocation (ToplevelVar v) m
| EVar v -> Expr.evar (Var.Map.find v ctx.var_mapping) m
@ -145,9 +140,7 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) :
~polymorphic:(fun op -> Expr.eapp (Expr.eop op tys m1) args m)
~overloaded:(fun op ->
match
Operator.resolve_overload ctx.decl_ctx
(Marked.mark (Expr.pos e) op)
tys
Operator.resolve_overload ctx.decl_ctx (Mark.add (Expr.pos e) op) tys
with
| op, `Straight -> Expr.eapp (Expr.eop op tys m1) args m
| op, `Reversed ->
@ -196,15 +189,15 @@ let rule_to_exception_graph (scope : Desugared.Ast.scope) = function
scope.scope_defs
in
let var_def = scope_def.D.scope_def_rules in
match Marked.unmark scope_def.Desugared.Ast.scope_def_io.io_input with
match Mark.remove scope_def.Desugared.Ast.scope_def_io.io_input with
| OnlyInput when not (RuleName.Map.is_empty var_def) ->
(* If the variable is tagged as input, then it shall not be redefined. *)
Errors.raise_multispanned_error
((Some "Incriminated variable:", Marked.get_mark (ScopeVar.get_info var))
((Some "Incriminated variable:", Mark.get (ScopeVar.get_info var))
:: List.map
(fun (rule, _) ->
( Some "Incriminated variable definition:",
Marked.get_mark (RuleName.get_info rule) ))
Mark.get (RuleName.get_info rule) ))
(RuleName.Map.bindings var_def))
"It is impossible to give a definition to a scope variable tagged as \
input."
@ -230,7 +223,7 @@ let rule_to_exception_graph (scope : Desugared.Ast.scope) = function
not visible in the input of the subscope *)
&& not
((match
Marked.unmark scope_def.Desugared.Ast.scope_def_io.io_input
Mark.remove scope_def.Desugared.Ast.scope_def_io.io_input
with
| Desugared.Ast.NoInput -> true
| _ -> false)
@ -249,18 +242,18 @@ let rule_to_exception_graph (scope : Desugared.Ast.scope) = function
we have to check that this redefinition is allowed with respect
to the io parameters of that subscope variable. *)
(match
Marked.unmark scope_def.Desugared.Ast.scope_def_io.io_input
Mark.remove scope_def.Desugared.Ast.scope_def_io.io_input
with
| Desugared.Ast.NoInput ->
Errors.raise_multispanned_error
(( Some "Incriminated subscope:",
Marked.get_mark (SubScopeName.get_info sscope) )
Mark.get (SubScopeName.get_info sscope) )
:: ( Some "Incriminated variable:",
Marked.get_mark (ScopeVar.get_info sub_scope_var) )
Mark.get (ScopeVar.get_info sub_scope_var) )
:: List.map
(fun (rule, _) ->
( Some "Incriminated subscope variable definition:",
Marked.get_mark (RuleName.get_info rule) ))
Mark.get (RuleName.get_info rule) ))
(RuleName.Map.bindings def))
"It is impossible to give a definition to a subscope variable \
not tagged as input or context."
@ -270,7 +263,7 @@ let rule_to_exception_graph (scope : Desugared.Ast.scope) = function
Errors.raise_multispanned_error
[
( Some "Incriminated subscope:",
Marked.get_mark (SubScopeName.get_info sscope) );
Mark.get (SubScopeName.get_info sscope) );
Some "Incriminated variable:", pos;
]
"This subscope variable is a mandatory input but no definition \
@ -375,10 +368,10 @@ let rec rule_tree_to_expr
match params, rule.Desugared.Ast.rule_parameter with
| Some new_params, Some (old_params_with_types, _) ->
let old_params, _ = List.split old_params_with_types in
let old_params = Array.of_list (List.map Marked.unmark old_params) in
let old_params = Array.of_list (List.map Mark.remove old_params) in
let new_params = Array.of_list new_params in
let binder = Bindlib.bind_mvar old_params (Marked.unmark e) in
Marked.mark (Marked.get_mark e)
let binder = Bindlib.bind_mvar old_params (Mark.remove e) in
Mark.add (Mark.get e)
@@ Bindlib.box_apply2
(fun binder new_param -> Bindlib.msubst binder new_param)
binder
@ -483,7 +476,7 @@ let translate_def
(ctx : ctx)
(def_info : Desugared.Ast.ScopeDef.t)
(def : Desugared.Ast.rule RuleName.Map.t)
(params : (Uid.MarkedString.info * typ) list Marked.pos option)
(params : (Uid.MarkedString.info * typ) list Mark.pos option)
(typ : typ)
(io : Desugared.Ast.io)
(exc_graph : Desugared.Dependency.ExceptionsDependencies.t) :
@ -491,12 +484,12 @@ let translate_def
(* Here, we have to transform this list of rules into a default tree. *)
let top_list = def_map_to_tree def exc_graph in
let is_input =
match Marked.unmark io.Desugared.Ast.io_input with
match Mark.remove io.Desugared.Ast.io_input with
| OnlyInput -> true
| _ -> false
in
let is_reentrant =
match Marked.unmark io.Desugared.Ast.io_input with
match Mark.remove io.Desugared.Ast.io_input with
| Reentrant -> true
| _ -> false
in
@ -544,7 +537,7 @@ let translate_def
let labels, tys = List.split ps in
Expr.make_abs
(Array.of_list
(List.map (fun lbl -> Var.make (Marked.unmark lbl)) labels))
(List.map (fun lbl -> Var.make (Mark.remove lbl)) labels))
empty_error tys (Expr.mark_pos m)
| _ -> empty_error
else
@ -552,13 +545,13 @@ let translate_def
(Desugared.Ast.ScopeDef.get_position def_info)
(Option.map
(fun (ps, _) ->
(List.map (fun (lbl, _) -> Var.make (Marked.unmark lbl))) ps)
(List.map (fun (lbl, _) -> Var.make (Mark.remove lbl))) ps)
params)
(match top_list, top_value with
| [], None ->
(* In this case, there are no rules to define the expression and no
default value so we put an empty rule. *)
Leaf [Desugared.Ast.empty_rule (Marked.get_mark typ) params]
Leaf [Desugared.Ast.empty_rule (Mark.get typ) params]
| [], Some top_value ->
(* In this case, there are no rules to define the expression but a
default value so we put it. *)
@ -569,7 +562,7 @@ let translate_def
Node (top_list, [top_value])
| [top_tree], None -> top_tree
| _, None ->
Node (top_list, [Desugared.Ast.empty_rule (Marked.get_mark typ) params]))
Node (top_list, [Desugared.Ast.empty_rule (Mark.get typ) params]))
let translate_rule
ctx
@ -587,7 +580,7 @@ let translate_rule
let var_params = scope_def.D.scope_def_parameters in
let var_typ = scope_def.D.scope_def_typ in
let is_cond = scope_def.D.scope_def_is_condition in
match Marked.unmark scope_def.Desugared.Ast.scope_def_io.io_input with
match Mark.remove scope_def.Desugared.Ast.scope_def_io.io_input with
| OnlyInput when not (RuleName.Map.is_empty var_def) ->
assert false (* error already raised *)
| OnlyInput -> []
@ -609,8 +602,8 @@ let translate_rule
[
Ast.Definition
( ( ScopelangScopeVar
(scope_var, Marked.get_mark (ScopeVar.get_info scope_var)),
Marked.get_mark (ScopeVar.get_info scope_var) ),
(scope_var, Mark.get (ScopeVar.get_info scope_var)),
Mark.get (ScopeVar.get_info scope_var) ),
var_typ,
scope_def.Desugared.Ast.scope_def_io,
Expr.unbox expr_def );
@ -632,7 +625,7 @@ let translate_rule
not visible in the input of the subscope *)
&& not
((match
Marked.unmark scope_def.Desugared.Ast.scope_def_io.io_input
Mark.remove scope_def.Desugared.Ast.scope_def_io.io_input
with
| Desugared.Ast.NoInput -> true
| _ -> false)
@ -652,7 +645,7 @@ let translate_rule
we have to check that this redefinition is allowed with respect
to the io parameters of that subscope variable. *)
(match
Marked.unmark scope_def.Desugared.Ast.scope_def_io.io_input
Mark.remove scope_def.Desugared.Ast.scope_def_io.io_input
with
| Desugared.Ast.NoInput -> assert false (* error already raised *)
| OnlyInput when RuleName.Map.is_empty def && not is_cond ->
@ -695,8 +688,7 @@ let translate_rule
Ast.Call
( sub_scope,
sub_scope_index,
Untyped
{ pos = Marked.get_mark (SubScopeName.get_info sub_scope_index) }
Untyped { pos = Mark.get (SubScopeName.get_info sub_scope_index) }
);
]
| Assertion a_name ->
@ -766,7 +758,7 @@ let translate_scope
acc states)
scope.scope_vars ScopeVar.Map.empty
in
let pos = Marked.get_mark (ScopeName.get_info scope.scope_uid) in
let pos = Mark.get (ScopeName.get_info scope.scope_uid) in
{
Ast.scope_decl_name = scope.scope_uid;
Ast.scope_decl_rules;
@ -801,8 +793,7 @@ let translate_program
let var_prefix = var_name ^ "_" in
let state_var state =
ScopeVar.fresh
(Marked.map_under_mark (( ^ ) var_prefix)
(StateName.get_info state))
(Mark.map (( ^ ) var_prefix) (StateName.get_info state))
in
States (List.map (fun state -> state, state_var state) states)
in

12
compiler/scopelang/print.ml
View File

@ -56,11 +56,11 @@ let scope ?debug ctx fmt (name, decl) =
Format.fprintf fmt "%a%a%a %a%a%a%a%a" Print.punctuation "("
ScopeVar.format_t scope_var Print.punctuation ":" (Print.typ ctx) typ
Print.punctuation "|" Print.keyword
(match Marked.unmark vis.Desugared.Ast.io_input with
(match Mark.remove vis.Desugared.Ast.io_input with
| NoInput -> "internal"
| OnlyInput -> "input"
| Reentrant -> "context")
(if Marked.unmark vis.Desugared.Ast.io_output then fun fmt () ->
(if Mark.remove vis.Desugared.Ast.io_output then fun fmt () ->
Format.fprintf fmt "%a@,%a" Print.punctuation "|" Print.keyword
"output"
else fun fmt () -> Format.fprintf fmt "@<0>")
@ -73,15 +73,15 @@ let scope ?debug ctx fmt (name, decl) =
match rule with
| Definition (loc, typ, _, e) ->
Format.fprintf fmt "@[<hov 2>%a %a %a %a %a@ %a@]" Print.keyword
"let" Print.location (Marked.unmark loc) Print.punctuation ":"
"let" Print.location (Mark.remove loc) Print.punctuation ":"
(Print.typ ctx) typ Print.punctuation "="
(fun fmt e ->
match Marked.unmark loc with
match Mark.remove loc with
| SubScopeVar _ | ToplevelVar _ -> Print.expr () fmt e
| ScopelangScopeVar v -> (
match
Marked.unmark
(snd (ScopeVar.Map.find (Marked.unmark v) decl.scope_sig))
Mark.remove
(snd (ScopeVar.Map.find (Mark.remove v) decl.scope_sig))
.io_input
with
| Reentrant ->

14
compiler/shared_ast/definitions.ml
View File

@ -138,7 +138,7 @@ type ('a, 'b) dcalc_lcalc =
type typ_lit = TBool | TUnit | TInt | TRat | TMoney | TDate | TDuration
type typ = naked_typ Marked.pos
type typ = naked_typ Mark.pos
and naked_typ =
| TLit of typ_lit
@ -305,19 +305,19 @@ type lit =
(** Locations are handled differently in [desugared] and [scopelang] *)
type 'a glocation =
| DesugaredScopeVar :
ScopeVar.t Marked.pos * StateName.t option
ScopeVar.t Mark.pos * StateName.t option
-> < scopeVarStates : yes ; .. > glocation
| ScopelangScopeVar :
ScopeVar.t Marked.pos
ScopeVar.t Mark.pos
-> < scopeVarSimpl : yes ; .. > glocation
| SubScopeVar :
ScopeName.t * SubScopeName.t Marked.pos * ScopeVar.t Marked.pos
ScopeName.t * SubScopeName.t Mark.pos * ScopeVar.t Mark.pos
-> < explicitScopes : yes ; .. > glocation
| ToplevelVar :
TopdefName.t Marked.pos
TopdefName.t Mark.pos
-> < explicitScopes : yes ; .. > glocation
type ('a, 't) gexpr = (('a, 't) naked_gexpr, 't) Marked.t
type ('a, 't) gexpr = (('a, 't) naked_gexpr, 't) Mark.ed
and ('a, 't) naked_gexpr = ('a, 'a, 't) base_gexpr
(** General expressions: groups all expression cases of the different ASTs, and
@ -436,7 +436,7 @@ and ('a, 'b, 't) base_gexpr =
(* Useful for errors and printing, for example *)
(* type any_expr = AnyExpr : ('a, _ mark) gexpr -> any_expr *)
type ('a, 't) boxed_gexpr = (('a, 't) naked_gexpr Bindlib.box, 't) Marked.t
type ('a, 't) boxed_gexpr = (('a, 't) naked_gexpr Bindlib.box, 't) Mark.ed
(** The annotation is lifted outside of the box for expressions *)
type 'e boxed = ('a, 't) boxed_gexpr constraint 'e = ('a, 't) gexpr

86
compiler/shared_ast/expr.ml
View File

@ -54,8 +54,7 @@ module Box = struct
mark )
let lift : ('a, 't) boxed_gexpr -> ('a, 't) gexpr B.box =
fun em ->
B.box_apply (fun e -> Marked.mark (Marked.get_mark em) e) (Marked.unmark em)
fun em -> B.box_apply (fun e -> Mark.add (Mark.get em) e) (Mark.remove em)
module LiftStruct = Bindlib.Lift (StructField.Map)
@ -107,9 +106,9 @@ end
let bind vars e = Bindlib.bind_mvar vars (Box.lift e)
let subst binder vars =
Bindlib.msubst binder (Array.of_list (List.map Marked.unmark vars))
Bindlib.msubst binder (Array.of_list (List.map Mark.remove vars))
let evar v mark = Marked.mark mark (Bindlib.box_var v)
let evar v mark = Mark.add mark (Bindlib.box_var v)
let etuple args = Box.appn args @@ fun args -> ETuple args
let etupleaccess e index size =
@ -117,7 +116,7 @@ let etupleaccess e index size =
Box.app1 e @@ fun e -> ETupleAccess { e; index; size }
let earray args = Box.appn args @@ fun args -> EArray args
let elit l mark = Marked.mark mark (Bindlib.box (ELit l))
let elit l mark = Mark.add mark (Bindlib.box (ELit l))
let eabs binder tys mark =
Bindlib.box_apply (fun binder -> EAbs { binder; tys }) binder, mark
@ -135,7 +134,7 @@ let eifthenelse cond etrue efalse =
@@ fun cond etrue efalse -> EIfThenElse { cond; etrue; efalse }
let eerroronempty e1 = Box.app1 e1 @@ fun e1 -> EErrorOnEmpty e1
let eemptyerror mark = Marked.mark mark (Bindlib.box EEmptyError)
let eemptyerror mark = Mark.add mark (Bindlib.box EEmptyError)
let eraise e1 = Box.app0 @@ ERaise e1
let ecatch body exn handler =
@ -144,7 +143,7 @@ let ecatch body exn handler =
let elocation loc = Box.app0 @@ ELocation loc
let estruct name (fields : ('a, 't) boxed_gexpr StructField.Map.t) mark =
Marked.mark mark
Mark.add mark
@@ Bindlib.box_apply
(fun fields -> EStruct { name; fields })
(Box.lift_struct (StructField.Map.map Box.lift fields))
@ -158,14 +157,14 @@ let estructaccess e field name =
let einj e cons name = Box.app1 e @@ fun e -> EInj { name; e; cons }
let ematch e name cases mark =
Marked.mark mark
Mark.add mark
@@ Bindlib.box_apply2
(fun e cases -> EMatch { name; e; cases })
(Box.lift e)
(Box.lift_enum (EnumConstructor.Map.map Box.lift cases))
let escopecall scope args mark =
Marked.mark mark
Mark.add mark
@@ Bindlib.box_apply
(fun args -> EScopeCall { scope; args })
(Box.lift_scope_vars (ScopeVar.Map.map Box.lift args))
@ -174,13 +173,12 @@ 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 = Marked.mark Pos.no_pos TAny }
| Typed _ -> Typed { pos = Pos.no_pos; ty = Mark.add Pos.no_pos TAny }
let mark_pos (type m) (m : m mark) : Pos.t =
match m with Untyped { pos } | Typed { pos; _ } -> pos
let pos (type m) (x : ('a, m mark) Marked.t) : Pos.t =
mark_pos (Marked.get_mark x)
let pos (type m) (x : ('a, m mark) Mark.ed) : Pos.t = mark_pos (Mark.get x)
let fun_id mark : ('a any, 'm mark) boxed_gexpr =
let x = Var.make "x" in
@ -188,13 +186,13 @@ let fun_id mark : ('a any, 'm mark) boxed_gexpr =
let ty (_, m) : typ = match m with Typed { ty; _ } -> ty
let set_ty (type m) (ty : typ) (x : ('a, m mark) Marked.t) :
('a, typed mark) Marked.t =
Marked.mark
(match Marked.get_mark x with
let set_ty (type m) (ty : typ) (x : ('a, m mark) Mark.ed) :
('a, typed mark) Mark.ed =
Mark.add
(match Mark.get x with
| Untyped { pos } -> Typed { pos; ty }
| Typed m -> Typed { m with ty })
(Marked.unmark x)
(Mark.remove x)
let map_mark (type m) (pos_f : Pos.t -> Pos.t) (ty_f : typ -> typ) (m : m mark)
: m mark =
@ -238,7 +236,7 @@ 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 } -> Marked.mark pos typ | Typed { ty; _ } -> ty
match m with Untyped { pos } -> Mark.add pos typ | Typed { ty; _ } -> ty
(* - Predefined types (option) - *)
@ -256,9 +254,9 @@ let option_enum_config =
let map
(type a b)
~(f : (a, 'm1) gexpr -> (b, 'm2) boxed_gexpr)
(e : ((a, b, 'm1) base_gexpr, 'm2) Marked.t) : (b, 'm2) boxed_gexpr =
let m = Marked.get_mark e in
match Marked.unmark e with
(e : ((a, b, 'm1) base_gexpr, 'm2) Mark.ed) : (b, 'm2) boxed_gexpr =
let m = Mark.get e in
match Mark.remove e with
| ELit l -> elit l m
| EApp { f = e1; args } -> eapp (f e1) (List.map f args) m
| EOp { op; tys } -> eop op tys m
@ -298,7 +296,7 @@ let map
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
map_top_down ~f:(Mark.map_mark f) e
(* Folds the given function on the direct children of the given expression. *)
let shallow_fold
@ -307,7 +305,7 @@ let shallow_fold
(e : (a, 'm) gexpr)
(acc : 'acc) : 'acc =
let lfold x acc = List.fold_left (fun acc x -> f x acc) acc x in
match Marked.unmark e with
match Mark.remove e with
| ELit _ | EOp _ | EVar _ | ERaise _ | ELocation _ | EEmptyError -> acc
| EApp { f = e; args } -> acc |> f e |> lfold args
| EArray args -> acc |> lfold args
@ -335,8 +333,8 @@ let map_gather
~(acc : 'acc)
~(join : 'acc -> 'acc -> 'acc)
~(f : (a, 'm1) gexpr -> 'acc * (a, 'm2) boxed_gexpr)
(e : ((a, 'm1) naked_gexpr, 'm2) Marked.t) : 'acc * (a, 'm2) boxed_gexpr =
let m = Marked.get_mark e in
(e : ((a, 'm1) naked_gexpr, 'm2) Mark.ed) : 'acc * (a, 'm2) boxed_gexpr =
let m = Mark.get e in
let lfoldmap es =
let acc, r_es =
List.fold_left
@ -347,7 +345,7 @@ let map_gather
in
acc, List.rev r_es
in
match Marked.unmark e with
match Mark.remove e with
| ELit l -> acc, elit l m
| EApp { f = e1; args } ->
let acc1, f = f e1 in
@ -437,14 +435,14 @@ let map_gather
(** See [Bindlib.box_term] documentation for why we are doing that. *)
let rec rebox (e : ('a any, 't) gexpr) = map ~f:rebox e
let box e = Marked.same_mark_as (Bindlib.box (Marked.unmark e)) e
let box e = Mark.map Bindlib.box e
let unbox (e, m) = Bindlib.unbox e, m
let untype e = map_marks ~f:(fun m -> Untyped { pos = mark_pos m }) e
(* Tests *)
let is_value (type a) (e : (a, _) gexpr) =
match Marked.unmark e with
match Mark.remove e with
| ELit _ | EAbs _ | EOp _ | ERaise _ -> true
| _ -> false
@ -499,13 +497,13 @@ let compare_lit (l1 : lit) (l2 : lit) =
let compare_location
(type a)
(x : a glocation Marked.pos)
(y : a glocation Marked.pos) =
match Marked.unmark x, Marked.unmark y with
(x : a glocation Mark.pos)
(y : a glocation Mark.pos) =
match Mark.remove x, Mark.remove y with
| DesugaredScopeVar (vx, None), DesugaredScopeVar (vy, None)
| DesugaredScopeVar (vx, Some _), DesugaredScopeVar (vy, None)
| DesugaredScopeVar (vx, None), DesugaredScopeVar (vy, Some _) ->
ScopeVar.compare (Marked.unmark vx) (Marked.unmark vy)
ScopeVar.compare (Mark.remove vx) (Mark.remove vy)
| DesugaredScopeVar ((x, _), Some sx), DesugaredScopeVar ((y, _), Some sy) ->
let cmp = ScopeVar.compare x y in
if cmp = 0 then StateName.compare sx sy else cmp
@ -537,7 +535,7 @@ let rec equal_list : 'a. ('a, 't) gexpr list -> ('a, 't) gexpr list -> bool =
and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool =
fun e1 e2 ->
match Marked.unmark e1, Marked.unmark e2 with
match Mark.remove e1, Mark.remove e2 with
| EVar v1, EVar v2 -> Bindlib.eq_vars v1 v2
| ETuple es1, ETuple es2 -> equal_list es1 es2
| ( ETupleAccess { e = e1; index = id1; size = s1 },
@ -565,7 +563,7 @@ and equal : type a. (a, 't) gexpr -> (a, 't) gexpr -> bool =
ECatch { body = etry2; exn = ex2; handler = ewith2 } ) ->
equal etry1 etry2 && equal_except ex1 ex2 && equal ewith1 ewith2
| ELocation l1, ELocation l2 ->
equal_location (Marked.mark Pos.no_pos l1) (Marked.mark Pos.no_pos l2)
equal_location (Mark.add Pos.no_pos l1) (Mark.add Pos.no_pos l2)
| ( EStruct { name = s1; fields = fields1 },
EStruct { name = s2; fields = fields2 } ) ->
StructName.equal s1 s2 && StructField.Map.equal equal fields1 fields2
@ -599,7 +597,7 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
let ( @@< ) cmp1 cmpf = match cmp1 with 0 -> cmpf () | n -> n in
(* OCamlformat doesn't know to keep consistency in match cases so disabled
locally for readability *)
match[@ocamlformat "disable"] Marked.unmark e1, Marked.unmark e2 with
match[@ocamlformat "disable"] Mark.remove e1, Mark.remove e2 with
| ELit l1, ELit l2 ->
compare_lit l1 l2
| EApp {f=f1; args=args1}, EApp {f=f2; args=args2} ->
@ -623,7 +621,7 @@ let rec compare : type a. (a, _) gexpr -> (a, _) gexpr -> int =
compare t1 t2 @@< fun () ->
compare e1 e2
| ELocation l1, ELocation l2 ->
compare_location (Marked.mark Pos.no_pos l1) (Marked.mark Pos.no_pos l2)
compare_location (Mark.add Pos.no_pos l1) (Mark.add Pos.no_pos l2)
| EStruct {name=name1; fields=field_map1},
EStruct {name=name2; fields=field_map2} ->
StructName.compare name1 name2 @@< fun () ->
@ -732,7 +730,7 @@ let format ppf e = Print.expr ~debug:false () ppf e
let rec size : type a. (a, 't) gexpr -> int =
fun e ->
match Marked.unmark e with
match Mark.remove e with
| EVar _ | ELit _ | EOp _ | EEmptyError -> 1
| ETuple args -> List.fold_left (fun acc arg -> acc + size arg) 1 args
| EArray args -> List.fold_left (fun acc arg -> acc + size arg) 1 args
@ -772,8 +770,8 @@ let make_abs xs e taus pos =
let mark =
map_mark
(fun _ -> pos)
(fun ety -> Marked.mark pos (TArrow (taus, ety)))
(Marked.get_mark e)
(fun ety -> Mark.add pos (TArrow (taus, ety)))
(Mark.get e)
in
eabs (bind xs e) taus mark
@ -784,7 +782,7 @@ let make_app e args pos =
(function
| [] -> assert false
| fty :: argtys -> (
match Marked.unmark fty.ty with
match Mark.remove fty.ty with
| TArrow (tx', tr) ->
assert (Type.unifiable_list tx' (List.map (fun x -> x.ty) argtys));
tr
@ -793,7 +791,7 @@ let make_app e args pos =
Errors.raise_internal_error
"wrong type: found %a while expecting either an Arrow or Any"
Print.typ_debug fty.ty))
(List.map Marked.get_mark (e :: args))
(List.map Mark.get (e :: args))
in
eapp e args mark
@ -805,7 +803,7 @@ let thunk_term term mark =
let empty_thunked_term mark = thunk_term (Bindlib.box EEmptyError, mark) mark
let unthunk_term_nobox term mark =
Marked.mark mark (EApp { f = term; args = [ELit LUnit, mark] })
Mark.add mark (EApp { f = term; args = [ELit LUnit, mark] })
let make_let_in x tau e1 e2 mpos =
make_app (make_abs [| x |] e2 [tau] mpos) [e1] (pos e2)
@ -826,7 +824,7 @@ let make_default_unboxed excepts just cons =
match excepts, bool_value just, cons with
| excepts, Some true, (EDefault { excepts = []; just; cons }, _) ->
EDefault { excepts; just; cons }
| [((EDefault _, _) as except)], Some false, _ -> Marked.unmark except
| [((EDefault _, _) as except)], Some false, _ -> Mark.remove except
| excepts, _, cons -> EDefault { excepts; just; cons }
let make_default exceptions just cons =
@ -841,6 +839,6 @@ let make_tuple el m0 =
fold_marks
(fun posl -> List.hd posl)
(fun ml -> TTuple (List.map (fun t -> t.ty) ml), (List.hd ml).pos)
(List.map (fun e -> Marked.get_mark e) el)
(List.map (fun e -> Mark.get e) el)
in
etuple el m

20
compiler/shared_ast/expr.mli
View File

@ -180,16 +180,16 @@ val option_enum_config : typ EnumConstructor.Map.t
(** Manipulation of marked expressions *)
val pos : ('a, 'm mark) Marked.t -> Pos.t
val ty : ('e, typed mark) Marked.t -> typ
val set_ty : typ -> ('a, 'm mark) Marked.t -> ('a, typed mark) Marked.t
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
(** {2 Traversal functions} *)
val map :
f:(('a, 'm1) gexpr -> ('b, 'm2) boxed_gexpr) ->
(('a, 'b, 'm1) base_gexpr, 'm2) Marked.t ->
(('a, 'b, 'm1) base_gexpr, 'm2) Mark.ed ->
('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.
@ -200,7 +200,7 @@ val map :
{[
let remove_error_empty e =
let rec f e =
match Marked.unmark e with
match Mark.remove e with
| EErrorOnEmpty e1 -> Expr.map ~f e1
| _ -> Expr.map ~f e
in
@ -223,7 +223,7 @@ val map :
becomes useful. *)
val map_top_down :
f:(('a, 't1) gexpr -> (('a, 't1) naked_gexpr, 't2) Marked.t) ->
f:(('a, 't1) gexpr -> (('a, 't1) naked_gexpr, 't2) Mark.ed) ->
('a, 't1) gexpr ->
('a, 't2) boxed_gexpr
(** Recursively applies [f] to the nodes of the expression tree. The type
@ -253,7 +253,7 @@ val map_gather :
acc:'acc ->
join:('acc -> 'acc -> 'acc) ->
f:(('a, 't1) gexpr -> 'acc * ('a, 't2) boxed_gexpr) ->
(('a, 't1) naked_gexpr, 't2) Marked.t ->
(('a, 't1) naked_gexpr, 't2) Mark.ed ->
'acc * ('a, 't2) boxed_gexpr
(** Shallow mapping similar to [map], but additionally allows to gather an
accumulator bottom-up. [acc] is the accumulator value returned on terminal
@ -263,7 +263,7 @@ val map_gather :
{[
let rec rewrite e =
match Marked.unmark e with
match Mark.remove e with
| Specific_case -> Var.Set.singleton x, some_rewrite_fun e
| _ ->
Expr.map_gather ~acc:Var.Set.empty ~join:Var.Set.union ~f:rewrite e
@ -355,8 +355,8 @@ val format : Format.formatter -> ('a, 'm mark) gexpr -> unit
val equal_lit : lit -> lit -> bool
val compare_lit : lit -> lit -> int
val equal_location : 'a glocation Marked.pos -> 'a glocation Marked.pos -> bool
val compare_location : 'a glocation Marked.pos -> 'a glocation Marked.pos -> int
val equal_location : 'a glocation Mark.pos -> 'a glocation Mark.pos -> bool
val compare_location : 'a glocation Mark.pos -> 'a glocation Mark.pos -> int
val equal_except : except -> except -> bool
val compare_except : except -> except -> int

91
compiler/shared_ast/interpreter.ml
View File

@ -26,7 +26,7 @@ module Runtime = Runtime_ocaml.Runtime
(** {1 Helpers} *)
let is_empty_error : type a. (a, 'm) gexpr -> bool =
fun e -> match Marked.unmark e with EEmptyError -> true | _ -> false
fun e -> match Mark.remove e with EEmptyError -> true | _ -> false
(** [e' = propagate_empty_error e f] return [EEmptyError] if [e] is
[EEmptyError], else it apply [f] on not-empty term [e]. *)
@ -67,7 +67,7 @@ let print_log entry infos pos e =
in
Cli.with_style [ANSITerminal.green] "%s" expr_str)
| PosRecordIfTrueBool -> (
match pos <> Pos.no_pos, Marked.unmark e with
match pos <> Pos.no_pos, Mark.remove e with
| true, ELit (LBool true) ->
Cli.log_format "%*s%a%s:\n%s" (!log_indent * 2) "" Print.log_entry entry
(Cli.with_style [ANSITerminal.green] "Definition applied")
@ -102,7 +102,7 @@ let handle_eq evaluate_operator pos e1 e2 =
try
List.for_all2
(fun e1 e2 ->
match Marked.unmark (evaluate_operator Eq pos [e1; e2]) with
match Mark.remove (evaluate_operator Eq pos [e1; e2]) with
| ELit (LBool b) -> b
| _ -> assert false
(* should not happen *))
@ -112,7 +112,7 @@ let handle_eq evaluate_operator pos e1 e2 =
StructName.equal s1 s2
&& StructField.Map.equal
(fun e1 e2 ->
match Marked.unmark (evaluate_operator Eq pos [e1; e2]) with
match Mark.remove (evaluate_operator Eq pos [e1; e2]) with
| ELit (LBool b) -> b
| _ -> assert false
(* should not happen *))
@ -123,7 +123,7 @@ let handle_eq evaluate_operator pos e1 e2 =
EnumName.equal en1 en2
&& EnumConstructor.equal i1 i2
&&
match Marked.unmark (evaluate_operator Eq pos [e1; e2]) with
match Mark.remove (evaluate_operator Eq pos [e1; e2]) with
| ELit (LBool b) -> b
| _ -> assert false
(* should not happen *)
@ -172,37 +172,34 @@ let rec evaluate_operator
propagate_empty_error_list args
@@ fun args ->
let open Runtime.Oper in
Marked.mark m
Mark.add m
@@
match op, args with
| Length, [(EArray es, _)] ->
ELit (LInt (Runtime.integer_of_int (List.length es)))
| Log (entry, infos), [e'] ->
print_log entry infos pos e';
Marked.unmark e'
Mark.remove e'
| Eq, [(e1, _); (e2, _)] ->
ELit (LBool (handle_eq (evaluate_operator evaluate_expr) m e1 e2))
| Map, [f; (EArray es, _)] ->
EArray
(List.map
(fun e' ->
evaluate_expr (Marked.same_mark_as (EApp { f; args = [e'] }) e'))
(fun e' -> evaluate_expr (Mark.copy e' (EApp { f; args = [e'] })))
es)
| Reduce, [_; default; (EArray [], _)] -> Marked.unmark default
| Reduce, [_; default; (EArray [], _)] -> Mark.remove default
| Reduce, [f; _; (EArray (x0 :: xn), _)] ->
Marked.unmark
Mark.remove
(List.fold_left
(fun acc x ->
evaluate_expr (Marked.same_mark_as (EApp { f; args = [acc; x] }) f))
evaluate_expr (Mark.copy f (EApp { f; args = [acc; x] })))
x0 xn)
| Concat, [(EArray es1, _); (EArray es2, _)] -> EArray (es1 @ es2)
| Filter, [f; (EArray es, _)] ->
EArray
(List.filter
(fun e' ->
match
evaluate_expr (Marked.same_mark_as (EApp { f; args = [e'] }) e')
with
match evaluate_expr (Mark.copy e' (EApp { f; args = [e'] })) with
| ELit (LBool b), _ -> b
| _ ->
Errors.raise_spanned_error
@ -211,10 +208,10 @@ let rec evaluate_operator
(should not happen if the term was well-typed)")
es)
| Fold, [f; init; (EArray es, _)] ->
Marked.unmark
Mark.remove
(List.fold_left
(fun acc e' ->
evaluate_expr (Marked.same_mark_as (EApp { f; args = [acc; e'] }) e'))
evaluate_expr (Mark.copy e' (EApp { f; args = [acc; e'] })))
init es)
| (Length | Log _ | Eq | Map | Concat | Filter | Fold | Reduce), _ -> err ()
| Not, [(ELit (LBool b), _)] -> ELit (LBool (o_not b))
@ -343,12 +340,12 @@ let rec evaluate_operator
match valid_exceptions with
| [] -> (
match
Marked.unmark (evaluate_expr (Expr.unthunk_term_nobox justification m))
Mark.remove (evaluate_expr (Expr.unthunk_term_nobox justification m))
with
| EInj { name; cons; e = ELit (LBool true), _ }
when EnumName.equal name Expr.option_enum
&& EnumConstructor.equal cons Expr.some_constr ->
Marked.unmark (evaluate_expr (Expr.unthunk_term_nobox conclusion m))
Mark.remove (evaluate_expr (Expr.unthunk_term_nobox conclusion m))
| EInj { name; cons; e = (ELit (LBool false), _) as e }
when EnumName.equal name Expr.option_enum
&& EnumConstructor.equal cons Expr.some_constr ->
@ -356,7 +353,7 @@ let rec evaluate_operator
{
name = Expr.option_enum;
cons = Expr.none_constr;
e = Marked.same_mark_as (ELit LUnit) e;
e = Mark.copy e (ELit LUnit);
}
| EInj { name; cons; e }
when EnumName.equal name Expr.option_enum
@ -365,7 +362,7 @@ let rec evaluate_operator
{
name = Expr.option_enum;
cons = Expr.none_constr;
e = Marked.same_mark_as (ELit LUnit) e;
e = Mark.copy e (ELit LUnit);
}
| _ -> err ())
| [((EInj { cons; name; _ } as e), _)]
@ -394,9 +391,9 @@ let rec evaluate_expr :
decl_ctx -> ((a, b) dcalc_lcalc, 'm) gexpr -> ((a, b) dcalc_lcalc, 'm) gexpr
=
fun ctx e ->
let m = Marked.get_mark e in
let m = Mark.get e in
let pos = Expr.mark_pos m in
match Marked.unmark e with
match Mark.remove e with
| EVar _ ->
Errors.raise_spanned_error pos
"free variable found at evaluation (should not happen if term was \
@ -406,11 +403,11 @@ let rec evaluate_expr :
let args = List.map (evaluate_expr ctx) args in
propagate_empty_error e1
@@ fun e1 ->
match Marked.unmark e1 with
match Mark.remove e1 with
| EAbs { binder; _ } ->
if Bindlib.mbinder_arity binder = List.length args then
evaluate_expr ctx
(Bindlib.msubst binder (Array.of_list (List.map Marked.unmark args)))
(Bindlib.msubst binder (Array.of_list (List.map Mark.remove args)))
else
Errors.raise_spanned_error pos
"wrong function call, expected %d arguments, got %d"
@ -421,13 +418,13 @@ let rec evaluate_expr :
Errors.raise_spanned_error pos
"function has not been reduced to a lambda at evaluation (should not \
happen if the term was well-typed")
| (EAbs _ | ELit _ | EOp _) as e -> Marked.mark m e (* these are values *)
| (EAbs _ | ELit _ | EOp _) as e -> Mark.add m e (* these are values *)
| EStruct { fields = es; name } ->
let fields, es = List.split (StructField.Map.bindings es) in
let es = List.map (evaluate_expr ctx) es in
propagate_empty_error_list es
@@ fun es ->
Marked.mark m
Mark.add m
(EStruct
{
fields =
@ -438,7 +435,7 @@ let rec evaluate_expr :
| EStructAccess { e; name = s; field } -> (
propagate_empty_error (evaluate_expr ctx e)
@@ fun e ->
match Marked.unmark e with
match Mark.remove e with
| EStruct { fields = es; name } -> (
if not (StructName.equal s name) then
Errors.raise_multispanned_error
@ -457,7 +454,7 @@ let rec evaluate_expr :
"The expression %a should be a struct %a but is not (should not happen \
if the term was well-typed)"
(Print.expr ()) e StructName.format_t s)
| ETuple es -> Marked.mark m (ETuple (List.map (evaluate_expr ctx) es))
| ETuple es -> Mark.add m (ETuple (List.map (evaluate_expr ctx) es))
| ETupleAccess { e = e1; index; size } -> (
match evaluate_expr ctx e1 with
| ETuple es, _ when List.length es = size -> List.nth es index
@ -468,11 +465,11 @@ let rec evaluate_expr :
(Print.expr ()) e size)
| EInj { e; name; cons } ->
propagate_empty_error (evaluate_expr ctx e)
@@ fun e -> Marked.mark m (EInj { e; name; cons })
@@ fun e -> Mark.add m (EInj { e; name; cons })
| EMatch { e; cases; name } -> (
propagate_empty_error (evaluate_expr ctx e)
@@ fun e ->
match Marked.unmark e with
match Mark.remove e with
| EInj { e = e1; cons; name = name' } ->
if not (EnumName.equal name name') then
Errors.raise_multispanned_error
@ -487,7 +484,7 @@ let rec evaluate_expr :
"sum type index error (should not happen if the term was \
well-typed)"
in
let new_e = Marked.mark m (EApp { f = es_n; args = [e1] }) in
let new_e = Mark.add m (EApp { f = es_n; args = [e1] }) in
evaluate_expr ctx new_e
| _ ->
Errors.raise_spanned_error (Expr.pos e)
@ -496,7 +493,7 @@ let rec evaluate_expr :
| EIfThenElse { cond; etrue; efalse } -> (
propagate_empty_error (evaluate_expr ctx cond)
@@ fun cond ->
match Marked.unmark cond with
match Mark.remove cond with
| ELit (LBool true) -> evaluate_expr ctx etrue
| ELit (LBool false) -> evaluate_expr ctx efalse
| _ ->
@ -505,13 +502,13 @@ let rec evaluate_expr :
not happen if the term was well-typed)")
| EArray es ->
propagate_empty_error_list (List.map (evaluate_expr ctx) es)
@@ fun es -> Marked.mark m (EArray es)
@@ fun es -> Mark.add m (EArray es)
| EAssert e' ->
propagate_empty_error (evaluate_expr ctx e') (fun e ->
match Marked.unmark e with
| ELit (LBool true) -> Marked.mark m (ELit LUnit)
match Mark.remove e with
| ELit (LBool true) -> Mark.add m (ELit LUnit)
| ELit (LBool false) -> (
match Marked.unmark (Expr.skip_wrappers e') with
match Mark.remove (Expr.skip_wrappers e') with
| EApp
{
f = EOp { op; _ }, _;
@ -528,7 +525,7 @@ let rec evaluate_expr :
Errors.raise_spanned_error (Expr.pos e')
"Expected a boolean literal for the result of this assertion \
(should not happen if the term was well-typed)")
| EEmptyError -> Marked.same_mark_as EEmptyError e
| EEmptyError -> Mark.copy e EEmptyError
| EErrorOnEmpty e' -> (
match evaluate_expr ctx e' with
| EEmptyError, _ ->
@ -542,10 +539,10 @@ let rec evaluate_expr :
match List.length excepts - empty_count with
| 0 -> (
let just = evaluate_expr ctx just in
match Marked.unmark just with
| EEmptyError -> Marked.mark m EEmptyError
match Mark.remove just with
| EEmptyError -> Mark.add m EEmptyError
| ELit (LBool true) -> evaluate_expr ctx cons
| ELit (LBool false) -> Marked.same_mark_as EEmptyError e
| ELit (LBool false) -> Mark.copy e EEmptyError
| _ ->
Errors.raise_spanned_error (Expr.pos e)
"Default justification has not been reduced to a boolean at \
@ -581,13 +578,13 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
let application_term =
StructField.Map.map
(fun ty ->
match Marked.unmark ty with
match Mark.remove ty with
| TOption _ ->
(Expr.einj (Expr.elit LUnit mark_e) Expr.none_constr
Expr.option_enum mark_e
: (_, _) boxed_gexpr)
| _ ->
Errors.raise_spanned_error (Marked.get_mark ty)
Errors.raise_spanned_error (Mark.get ty)
"This scope needs input arguments to be executed. But the Catala \
built-in interpreter does not have a way to retrieve input \
values from the command line, so it cannot execute this scope. \
@ -600,7 +597,7 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
[Expr.estruct s_in application_term mark_e]
(Expr.pos e)
in
match Marked.unmark (evaluate_expr ctx (Expr.unbox to_interpret)) with
match Mark.remove (evaluate_expr ctx (Expr.unbox to_interpret)) with
| EStruct { fields; _ } ->
List.map
(fun (fld, e) -> StructField.get_info fld, e)
@ -631,14 +628,14 @@ let interpret_program_dcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
let application_term =
StructField.Map.map
(fun ty ->
match Marked.unmark ty with
match Mark.remove ty with
| TArrow (ty_in, ty_out) ->
Expr.make_abs
(Array.of_list @@ List.map (fun _ -> Var.make "_") ty_in)
(Bindlib.box EEmptyError, Expr.with_ty mark_e ty_out)
ty_in (Expr.mark_pos mark_e)
| _ ->
Errors.raise_spanned_error (Marked.get_mark ty)
Errors.raise_spanned_error (Mark.get ty)
"This scope needs input arguments to be executed. But the Catala \
built-in interpreter does not have a way to retrieve input \
values from the command line, so it cannot execute this scope. \
@ -651,7 +648,7 @@ let interpret_program_dcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
[Expr.estruct s_in application_term mark_e]
(Expr.pos e)
in
match Marked.unmark (evaluate_expr ctx (Expr.unbox to_interpret)) with
match Mark.remove (evaluate_expr ctx (Expr.unbox to_interpret)) with
| EStruct { fields; _ } ->
List.map
(fun (fld, e) -> StructField.get_info fld, e)

17
compiler/shared_ast/operator.ml
View File

@ -513,35 +513,34 @@ 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) :
let resolve_overload ctx (op : overloaded t Mark.pos) (operands : typ list) :
< resolved : yes ; .. > t * [ `Straight | `Reversed ] =
try
let operands =
List.map
(fun t ->
match Marked.unmark t with TLit tl -> tl | _ -> raise Not_found)
match Mark.remove t with TLit tl -> tl | _ -> raise Not_found)
operands
in
resolve_overload_aux (Marked.unmark op) operands
resolve_overload_aux (Mark.remove op) operands
with Not_found ->
Errors.raise_multispanned_error
((None, Marked.get_mark op)
((None, Mark.get op)
:: List.map
(fun ty ->
( Some
(Format.asprintf "Type %a coming from expression:"
(Print.typ ctx) ty),
Marked.get_mark ty ))
Mark.get ty ))
operands)
"I don't know how to apply operator %a on types %a"
(Print.operator ~debug:true)
(Marked.unmark op)
(Mark.remove op)
(Format.pp_print_list
~pp_sep:(fun ppf () -> Format.fprintf ppf " and@ ")
(Print.typ ctx))
operands
let overload_type ctx (op : overloaded t Marked.pos) (operands : typ list) : typ
=
let overload_type ctx (op : overloaded t Mark.pos) (operands : typ list) : typ =
let rop = fst (resolve_overload ctx op operands) in
resolved_type (Marked.same_mark_as rop op)
resolved_type (Mark.copy op rop)

8
compiler/shared_ast/operator.mli
View File

@ -65,10 +65,10 @@ val translate : 'a no_overloads t -> 'b no_overloads t
(** {2 Getting the types of operators} *)
val monomorphic_type : monomorphic t Marked.pos -> typ
val resolved_type : resolved t Marked.pos -> typ
val monomorphic_type : monomorphic t Mark.pos -> typ
val resolved_type : resolved t Mark.pos -> typ
val overload_type : decl_ctx -> overloaded t Marked.pos -> typ list -> typ
val overload_type : decl_ctx -> overloaded t Mark.pos -> typ list -> typ
(** The type for typing overloads is different since the types of the operands
are required in advance.
@ -81,7 +81,7 @@ val overload_type : decl_ctx -> overloaded t Marked.pos -> typ list -> typ
val resolve_overload :
decl_ctx ->
overloaded t Marked.pos ->
overloaded t Mark.pos ->
typ list ->
< resolved : yes ; .. > t * [ `Straight | `Reversed ]
(** Some overloads are sugar for an operation with reversed operands, e.g.

52
compiler/shared_ast/optimizations.ml
View File

@ -27,12 +27,12 @@ type ('a, 'b, 'm) optimizations_ctx = {
let all_match_cases_are_id_fun cases n =
EnumConstructor.MapLabels.for_all cases ~f:(fun i case ->
match Marked.unmark case with
match Mark.remove case with
| EAbs { binder; _ } -> (
let var, body = Bindlib.unmbind binder in
(* because of invariant [invariant_match], the arity is always one. *)
let[@warning "-8"] [| var |] = var in
match Marked.unmark body with
match Mark.remove body with
| EInj { cons = i'; name = n'; e = EVar x, _ } ->
EnumConstructor.equal i i'
&& EnumName.equal n n'
@ -49,10 +49,10 @@ let all_match_cases_are_id_fun cases n =
let all_match_cases_map_to_same_constructor cases n =
EnumConstructor.MapLabels.for_all cases ~f:(fun i case ->
match Marked.unmark case with
match Mark.remove case with
| EAbs { binder; _ } -> (
let _, body = Bindlib.unmbind binder in
match Marked.unmark body with
match Mark.remove body with
| EInj { cons = i'; name = n'; _ } ->
EnumConstructor.equal i i' && EnumName.equal n n'
| _ -> false)
@ -66,13 +66,13 @@ let rec optimize_expr :
fun ctx e ->
(* We proceed bottom-up, first apply on the subterms *)
let e = Expr.map ~f:(optimize_expr ctx) e in
let mark = Marked.get_mark e in
let mark = Mark.get e in
(* Then reduce the parent node *)
let reduce (e : ((a, b) dcalc_lcalc, 'm mark) 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 *)
match Marked.unmark e with
match Mark.remove e with
| EApp
{
f =
@ -105,7 +105,7 @@ let rec optimize_expr :
(* reduction of logical or *)
match e1, e2 with
| (ELit (LBool false), _), new_e | new_e, (ELit (LBool false), _) ->
Marked.unmark new_e
Mark.remove new_e
| (ELit (LBool true), _), _ | _, (ELit (LBool true), _) ->
ELit (LBool true)
| _ -> EApp { f = op; args = [e1; e2] })
@ -124,7 +124,7 @@ let rec optimize_expr :
(* reduction of logical and *)
match e1, e2 with
| (ELit (LBool true), _), new_e | new_e, (ELit (LBool true), _) ->
Marked.unmark new_e
Mark.remove new_e
| (ELit (LBool false), _), _ | _, (ELit (LBool false), _) ->
ELit (LBool false)
| _ -> EApp { f = op; args = [e1; e2] })
@ -132,16 +132,16 @@ let rec optimize_expr :
(* iota-reduction *)
when EnumName.equal n n' -> (
(* match E x with | E y -> e1 = e1[y |-> x]*)
match Marked.unmark @@ EnumConstructor.Map.find cons cases with
match Mark.remove @@ EnumConstructor.Map.find cons cases with
(* holds because of invariant_match_inversion *)
| EAbs { binder; _ } ->
Marked.unmark
Mark.remove
(Bindlib.msubst binder ([e'] |> List.map fst |> Array.of_list))
| _ -> assert false)
| EMatch { e = e'; cases; name = n } when all_match_cases_are_id_fun cases n
->
(* iota-reduction when the match is equivalent to an identity function *)
Marked.unmark e'
Mark.remove e'
| EMatch
{
e = EMatch { e = arg; cases = cases1; name = n1 }, _;
@ -159,11 +159,11 @@ let rec optimize_expr :
EnumConstructor.MapLabels.merge cases1 cases2 ~f:(fun _i o1 o2 ->
match o1, o2 with
| Some b1, Some e2 -> (
match Marked.unmark b1, Marked.unmark e2 with
match Mark.remove b1, Mark.remove e2 with
| EAbs { binder = b1; _ }, EAbs { binder = b2; tys } -> (
let v1, e1 = Bindlib.unmbind b1 in
let[@warning "-8"] [| v1 |] = v1 in
match Marked.unmark e1 with
match Mark.remove e1 with
| EInj { e = e1; _ } ->
Some
(Expr.unbox
@ -179,14 +179,14 @@ let rec optimize_expr :
EMatch { e = arg; cases; name = n1 }
| EApp { f = EAbs { binder; _ }, _; args } ->
(* beta reduction *)
Marked.unmark (Bindlib.msubst binder (List.map fst args |> Array.of_list))
Mark.remove (Bindlib.msubst binder (List.map fst args |> Array.of_list))
| EStructAccess { name; field; e = EStruct { name = name1; fields }, _ }
when name = name1 ->
Marked.unmark (StructField.Map.find field fields)
Mark.remove (StructField.Map.find field fields)
| EDefault { excepts; just; cons } -> (
(* TODO: mechanically prove each of these optimizations correct :) *)
let excepts =
List.filter (fun except -> Marked.unmark except <> EEmptyError) excepts
List.filter (fun except -> Mark.remove except <> EEmptyError) excepts
(* we can discard the exceptions that are always empty error *)
in
let value_except_count =
@ -198,13 +198,13 @@ let rec optimize_expr :
(* at this point we know a conflict error will be triggered so we just
feed the expression to the interpreter that will print the beautiful
right error message *)
Marked.unmark (Interpreter.evaluate_expr ctx.decl_ctx e)
Mark.remove (Interpreter.evaluate_expr ctx.decl_ctx e)
else
match excepts, just with
| [except], _ when Expr.is_value except ->
(* if there is only one exception and it is a non-empty value it is
always chosen *)
Marked.unmark except
Mark.remove except
| ( [],
( ( ELit (LBool true)
| EApp
@ -213,7 +213,7 @@ let rec optimize_expr :
args = [(ELit (LBool true), _)];
} ),
_ ) ) ->
Marked.unmark cons
Mark.remove cons
| ( [],
( ( ELit (LBool false)
| EApp
@ -237,7 +237,7 @@ let rec optimize_expr :
etrue;
_;
} ->
Marked.unmark etrue
Mark.remove etrue
| EIfThenElse
{
cond =
@ -251,7 +251,7 @@ let rec optimize_expr :
efalse;
_;
} ->
Marked.unmark efalse
Mark.remove efalse
| EIfThenElse
{
cond;
@ -272,7 +272,7 @@ let rec optimize_expr :
} ),
_ );
} ->
if btrue && not bfalse then Marked.unmark cond
if btrue && not bfalse then Mark.remove cond
else if (not btrue) && bfalse then
EApp
{
@ -285,7 +285,7 @@ let rec optimize_expr :
| EApp { f = EOp { op = Op.Fold; _ }, _; args = [_f; init; (EArray [], _)] }
->
(*reduces a fold with an empty list *)
Marked.unmark init
Mark.remove init
| EApp
{ f = EOp { op = Op.Fold; _ }, _; args = [f; init; (EArray [e'], _)] }
->
@ -293,10 +293,10 @@ let rec optimize_expr :
EApp { f; args = [init; e'] }
| ECatch { body; exn; handler } -> (
(* peephole exception catching reductions *)
match Marked.unmark body, Marked.unmark handler with
match Mark.remove body, Mark.remove handler with
| ERaise exn', ERaise exn'' when exn' = exn && exn = exn'' -> ERaise exn
| ERaise exn', _ when exn' = exn -> Marked.unmark handler
| _, ERaise exn' when exn' = exn -> Marked.unmark body
| ERaise exn', _ when exn' = exn -> Mark.remove handler
| _, ERaise exn' when exn' = exn -> Mark.remove body
| _ -> ECatch { body; exn; handler })
| e -> e
in

20
compiler/shared_ast/print.ml
View File

@ -18,7 +18,7 @@ open Catala_utils
open Definitions
let typ_needs_parens (ty : typ) : bool =
match Marked.unmark ty with TArrow _ | TArray _ -> true | _ -> false
match Mark.remove ty with TArrow _ | TArray _ -> true | _ -> false
let uid_list (fmt : Format.formatter) (infos : Uid.MarkedString.info list) :
unit =
@ -26,7 +26,7 @@ let uid_list (fmt : Format.formatter) (infos : Uid.MarkedString.info list) :
~pp_sep:(fun fmt () -> Format.pp_print_char fmt '.')
(fun fmt info ->
Cli.format_with_style
(if String.begins_with_uppercase (Marked.unmark info) then
(if String.begins_with_uppercase (Mark.remove info) then
[ANSITerminal.red]
else [])
fmt
@ -61,12 +61,12 @@ let tlit (fmt : Format.formatter) (l : typ_lit) : unit =
let location (type a) (fmt : Format.formatter) (l : a glocation) : unit =
match l with
| DesugaredScopeVar (v, _st) -> ScopeVar.format_t fmt (Marked.unmark v)
| ScopelangScopeVar v -> ScopeVar.format_t fmt (Marked.unmark v)
| DesugaredScopeVar (v, _st) -> ScopeVar.format_t fmt (Mark.remove v)
| ScopelangScopeVar v -> ScopeVar.format_t fmt (Mark.remove v)
| SubScopeVar (_, subindex, subvar) ->
Format.fprintf fmt "%a.%a" SubScopeName.format_t (Marked.unmark subindex)
ScopeVar.format_t (Marked.unmark subvar)
| ToplevelVar v -> TopdefName.format_t fmt (Marked.unmark v)
Format.fprintf fmt "%a.%a" SubScopeName.format_t (Mark.remove subindex)
ScopeVar.format_t (Mark.remove subvar)
| ToplevelVar v -> TopdefName.format_t fmt (Mark.remove v)
let enum_constructor (fmt : Format.formatter) (c : EnumConstructor.t) : unit =
Cli.format_with_style [ANSITerminal.magenta] fmt
@ -81,7 +81,7 @@ let rec typ (ctx : decl_ctx option) (fmt : Format.formatter) (ty : typ) : unit =
let typ_with_parens (fmt : Format.formatter) (t : typ) =
if typ_needs_parens t then Format.fprintf fmt "(%a)" typ t else typ fmt t
in
match Marked.unmark ty with
match Mark.remove ty with
| TLit l -> tlit fmt l
| TTuple ts ->
Format.fprintf fmt "@[<hov 2>(%a)@]"
@ -341,7 +341,7 @@ module Precedence = struct
let expr : type a. (a, 't) gexpr -> t =
fun e ->
match Marked.unmark e with
match Mark.remove e with
| ELit _ -> Contained (* Todo: unop if < 0 *)
| EApp { f = EOp { op; _ }, _; _ } -> (
match op with
@ -465,7 +465,7 @@ let rec expr_aux :
in
let lhs ?(colors = colors) ex = paren ~colors ~rhs:false ex in
let rhs ex = paren ~rhs:true ex in
match Marked.unmark e with
match Mark.remove e with
| EVar v -> var fmt v
| ETuple es ->
Format.fprintf fmt "@[<hov 2>%a%a%a@]" punctuation "("

17
compiler/shared_ast/scope.ml
View File

@ -50,8 +50,7 @@ let map_exprs_in_lets :
scope_let_next;
scope_let_expr;
scope_let_typ =
(if reset_types then
Marked.same_mark_as TAny scope_let.scope_let_typ
(if reset_types then Mark.copy scope_let.scope_let_typ TAny
else scope_let.scope_let_typ);
})
(Bindlib.bind_var (varf var_next) acc)
@ -134,8 +133,8 @@ let rec get_body_expr_mark = function
let _, e = Bindlib.unbind sl.scope_let_next in
get_body_expr_mark e
| Result e ->
let m = Marked.get_mark e in
Expr.with_ty m (Marked.mark (Expr.mark_pos m) TAny)
let m = Mark.get e in
Expr.with_ty m (Mark.add (Expr.mark_pos m) TAny)
let get_body_mark scope_body =
let _, e = Bindlib.unbind scope_body.scope_body_expr in
@ -163,9 +162,9 @@ let build_typ_from_sig
(scope_input_struct_name : StructName.t)
(scope_return_struct_name : StructName.t)
(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))
let input_typ = Mark.add pos (TStruct scope_input_struct_name) in
let result_typ = Mark.add pos (TStruct scope_return_struct_name) in
Mark.add pos (TArrow ([input_typ], result_typ))
type 'e scope_name_or_var = ScopeName of ScopeName.t | ScopeVar of 'e Var.t
@ -192,7 +191,7 @@ let rec unfold
let typ, expr, pos, is_main =
match item with
| ScopeDef (name, body) ->
let pos = Marked.get_mark (ScopeName.get_info name) in
let pos = Mark.get (ScopeName.get_info name) in
let body_mark = get_body_mark body in
let is_main =
match main_scope with
@ -206,7 +205,7 @@ let rec unfold
let expr = to_expr ctx body body_mark in
typ, expr, pos, is_main
| Topdef (name, typ, expr) ->
let pos = Marked.get_mark (TopdefName.get_info name) in
let pos = Mark.get (TopdefName.get_info name) in
typ, Expr.rebox expr, pos, false
in
let main_scope = if is_main then ScopeVar var else main_scope in

6
compiler/shared_ast/type.ml
View File

@ -23,7 +23,7 @@ let equal_tlit l1 l2 = l1 = l2
let compare_tlit l1 l2 = Stdlib.compare l1 l2
let rec equal ty1 ty2 =
match Marked.unmark ty1, Marked.unmark ty2 with
match Mark.remove ty1, Mark.remove ty2 with
| TLit l1, TLit l2 -> equal_tlit l1 l2
| TTuple tys1, TTuple tys2 -> equal_list tys1 tys2
| TStruct n1, TStruct n2 -> StructName.equal n1 n2
@ -42,7 +42,7 @@ and equal_list tys1 tys2 =
(* Similar to [equal], but allows TAny holes *)
let rec unifiable ty1 ty2 =
match Marked.unmark ty1, Marked.unmark ty2 with
match Mark.remove ty1, Mark.remove ty2 with
| TAny, _ | _, TAny -> true
| TLit l1, TLit l2 -> equal_tlit l1 l2
| TTuple tys1, TTuple tys2 -> unifiable_list tys1 tys2
@ -60,7 +60,7 @@ and unifiable_list tys1 tys2 =
try List.for_all2 unifiable tys1 tys2 with Invalid_argument _ -> false
let rec compare ty1 ty2 =
match Marked.unmark ty1, Marked.unmark ty2 with
match Mark.remove ty1, Mark.remove ty2 with
| TLit l1, TLit l2 -> compare_tlit l1 l2
| TTuple tys1, TTuple tys2 -> List.compare compare tys1 tys2
| TStruct n1, TStruct n2 -> StructName.compare n1 n2

66
compiler/shared_ast/typing.ml
View File

@ -32,7 +32,7 @@ module Any =
end)
()
type unionfind_typ = naked_typ Marked.pos UnionFind.elem
type unionfind_typ = naked_typ Mark.pos UnionFind.elem
(** We do not reuse {!type: Shared_ast.typ} because we have to include a new
[TAny] variant. Indeed, error terms can have any type and this has to be
captured by the type sytem. *)
@ -69,7 +69,7 @@ let rec typ_to_ast ~leave_unresolved (ty : unionfind_typ) : A.typ =
let rec ast_to_typ (ty : A.typ) : unionfind_typ =
let ty' =
match Marked.unmark ty with
match Mark.remove ty with
| A.TLit l -> TLit l
| A.TArrow (t1, t2) -> TArrow (List.map ast_to_typ t1, ast_to_typ t2)
| A.TTuple ts -> TTuple (List.map ast_to_typ ts)
@ -79,13 +79,13 @@ let rec ast_to_typ (ty : A.typ) : unionfind_typ =
| A.TArray t -> TArray (ast_to_typ t)
| A.TAny -> TAny (Any.fresh ())
in
UnionFind.make (Marked.same_mark_as ty' ty)
UnionFind.make (Mark.copy ty ty')
(** {1 Types and unification} *)
let typ_needs_parens (t : unionfind_typ) : bool =
let t = UnionFind.get (UnionFind.find t) in
match Marked.unmark t with
match Mark.remove t with
| TArrow _ | TArray _ | TOption _ -> true
| _ -> false
@ -99,7 +99,7 @@ let rec format_typ
else Format.fprintf fmt "%a" format_typ t
in
let naked_typ = UnionFind.get (UnionFind.find naked_typ) in
match Marked.unmark naked_typ with
match Mark.remove naked_typ with
| TLit l -> Format.fprintf fmt "%a" Print.tlit l
| TTuple ts ->
Format.fprintf fmt "@[<hov 2>(%a)@]"
@ -121,7 +121,7 @@ let rec format_typ
format_typ_with_parens)
t1 format_typ t2
| TArray t1 -> (
match Marked.unmark (UnionFind.get (UnionFind.find t1)) with
match Mark.remove (UnionFind.get (UnionFind.find t1)) with
| TAny _ when not !Cli.debug_flag -> Format.pp_print_string fmt "collection"
| _ -> Format.fprintf fmt "@[collection@ %a@]" format_typ t1)
| TAny v ->
@ -146,7 +146,7 @@ let rec unify
let t2_repr = UnionFind.get (UnionFind.find t2) in
let raise_type_error () = raise (Type_error (A.AnyExpr e, t1, t2)) in
let () =
match Marked.unmark t1_repr, Marked.unmark t2_repr with
match Mark.remove t1_repr, Mark.remove t2_repr with
| TLit tl1, TLit tl2 -> if tl1 <> tl2 then raise_type_error ()
| TArrow (t11, t12), TArrow (t21, t22) -> (
unify e t12 t22;
@ -169,7 +169,7 @@ let rec unify
in
ignore
@@ UnionFind.merge
(fun t1 t2 -> match Marked.unmark t2 with TAny _ -> t1 | _ -> t2)
(fun t1 t2 -> match Mark.remove t2 with TAny _ -> t1 | _ -> t2)
t1 t2
let handle_type_error ctx e t1 t2 =
@ -178,12 +178,12 @@ let handle_type_error ctx e t1 t2 =
let pos =
match e with
| A.AnyExpr e -> (
match Marked.get_mark e with Untyped { pos } | Typed { pos; _ } -> pos)
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 = Marked.get_mark t1_repr in
let t2_pos = Marked.get_mark t2_repr in
let t1_pos = Mark.get t1_repr in
let t2_pos = Mark.get t2_repr in
let unformat_typ typ =
let buf = Buffer.create 59 in
let ppf = Format.formatter_of_buffer buf in
@ -229,10 +229,10 @@ let lit_type (lit : A.lit) : naked_typ =
functions separate. In particular [resolve_overloads] requires its argument
types to be known in advance. *)
let polymorphic_op_type (op : Operator.polymorphic A.operator Marked.pos) :
let polymorphic_op_type (op : Operator.polymorphic A.operator Mark.pos) :
unionfind_typ =
let open Operator in
let pos = Marked.get_mark op in
let pos = Mark.get op in
let any = lazy (UnionFind.make (TAny (Any.fresh ()), pos)) in
let any2 = lazy (UnionFind.make (TAny (Any.fresh ()), pos)) in
let bt = lazy (UnionFind.make (TLit TBool, pos)) in
@ -244,7 +244,7 @@ let polymorphic_op_type (op : Operator.polymorphic A.operator Marked.pos) :
lazy (UnionFind.make (TArrow (List.map Lazy.force x, Lazy.force y), pos))
in
let ty =
match Marked.unmark op with
match Mark.remove op with
| Fold -> [[any2; any] @-> any2; any2; array any] @-> any2
| Eq -> [any; any] @-> bt
| Map -> [[any] @-> any2; array any] @-> array any2
@ -269,7 +269,7 @@ let resolve_overload_ret_type
tys : unionfind_typ =
let op_ty =
Operator.overload_type ctx
(Marked.mark (Expr.pos e) op)
(Mark.add (Expr.pos e) op)
(List.map (typ_to_ast ~leave_unresolved) tys)
(* We use [unsafe] because the error is caught below *)
in
@ -335,7 +335,7 @@ module Env = struct
{ t with scope_vars }
end
let add_pos e ty = Marked.mark (Expr.pos e) ty
let add_pos e ty = Mark.add (Expr.pos e) ty
let ty (_, { uf; _ }) = uf
(** Infers the most permissive type from an expression *)
@ -367,7 +367,7 @@ and typecheck_expr_top_down :
let () =
(* If there already is a type annotation on the given expr, ensure it
matches *)
match Marked.get_mark e with
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)
in
@ -379,15 +379,15 @@ and typecheck_expr_top_down :
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
match Marked.unmark e with
match Mark.remove e with
| A.ELocation loc ->
let ty_opt =
match loc with
| DesugaredScopeVar (v, _) | ScopelangScopeVar v ->
Env.get_scope_var env (Marked.unmark v)
Env.get_scope_var env (Mark.remove v)
| SubScopeVar (scope, _, v) ->
Env.get_subscope_out_var env scope (Marked.unmark v)
| ToplevelVar v -> Env.get_toplevel_var env (Marked.unmark v)
Env.get_subscope_out_var env scope (Mark.remove v)
| ToplevelVar v -> Env.get_toplevel_var env (Mark.remove v)
in
let ty =
match ty_opt with
@ -415,7 +415,7 @@ and typecheck_expr_top_down :
List.map
(fun (f, ty) ->
( Some (Format.asprintf "Missing field %a" A.StructField.format_t f),
Marked.get_mark ty ))
Mark.get ty ))
(A.StructField.Map.bindings missing_fields)
@ List.map
(fun (f, ef) ->
@ -514,7 +514,7 @@ and typecheck_expr_top_down :
[
None, pos_e;
( Some "Structure %a declared here",
Marked.get_mark (A.StructName.get_info name) );
Mark.get (A.StructName.get_info name) );
]
"Structure %a doesn't define a field %a" A.StructName.format_t name
A.StructField.format_t field
@ -744,13 +744,11 @@ and typecheck_expr_top_down :
let tys, mark =
Operator.kind_dispatch op
~polymorphic:(fun op ->
( tys,
mark_with_tau_and_unify (polymorphic_op_type (Marked.mark pos_e op))
))
tys, mark_with_tau_and_unify (polymorphic_op_type (Mark.add pos_e op)))
~monomorphic:(fun op ->
let mark =
mark_with_tau_and_unify
(ast_to_typ (Operator.monomorphic_type (Marked.mark pos_e op)))
(ast_to_typ (Operator.monomorphic_type (Mark.add pos_e op)))
in
List.map (typ_to_ast ~leave_unresolved) tys', mark)
~overloaded:(fun op ->
@ -761,7 +759,7 @@ and typecheck_expr_top_down :
~resolved:(fun op ->
let mark =
mark_with_tau_and_unify
(ast_to_typ (Operator.resolved_type (Marked.mark pos_e op)))
(ast_to_typ (Operator.resolved_type (Mark.add pos_e op)))
in
List.map (typ_to_ast ~leave_unresolved) tys', mark)
in
@ -884,7 +882,7 @@ let rec scope_body_expr ~leave_unresolved ctx env ty_out body_expr =
{
scope_let_kind;
scope_let_typ =
(match Marked.unmark scope_let_typ with
(match Mark.remove scope_let_typ with
| TAny -> typ_to_ast ~leave_unresolved (ty e)
| _ -> scope_let_typ);
scope_let_expr;
@ -895,11 +893,9 @@ let rec scope_body_expr ~leave_unresolved ctx env ty_out body_expr =
scope_let_next
let scope_body ~leave_unresolved ctx env body =
let get_pos struct_name =
Marked.get_mark (A.StructName.get_info struct_name)
in
let get_pos struct_name = Mark.get (A.StructName.get_info struct_name) in
let struct_ty struct_name =
UnionFind.make (Marked.mark (get_pos struct_name) (TStruct struct_name))
UnionFind.make (Mark.add (get_pos struct_name) (TStruct struct_name))
in
let ty_in = struct_ty body.A.scope_body_input_struct in
let ty_out = struct_ty body.A.scope_body_output_struct in
@ -910,7 +906,7 @@ let scope_body ~leave_unresolved ctx env body =
(fun scope_body_expr -> { body with scope_body_expr })
(Bindlib.bind_var (Var.translate var) e'),
UnionFind.make
(Marked.mark
(Mark.add
(get_pos body.A.scope_body_output_struct)
(TArrow ([ty_in], ty_out))) )
@ -926,7 +922,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 = (Marked.get_mark e').uf in
let uf = (Mark.get e').uf in
let e' = Expr.map_marks ~f:(get_ty_mark ~leave_unresolved) e' in
( Env.add var uf env,
Bindlib.box_apply

211
compiler/surface/ast.ml
View File

@ -42,33 +42,33 @@ type lident = (string[@opaque])
visitors { variety = "iter"; name = "lident_iter"; nude = true }]
(** Idents are snake_case *)
type path = uident Marked.pos list
type path = uident Mark.pos list
[@@deriving
visitors
{
variety = "map";
ancestors = ["Marked.pos_map"; "uident_map"];
ancestors = ["Mark.pos_map"; "uident_map"];
name = "path_map";
},
visitors
{
variety = "iter";
ancestors = ["Marked.pos_iter"; "uident_iter"];
ancestors = ["Mark.pos_iter"; "uident_iter"];
name = "path_iter";
}]
type scope_var = lident Marked.pos list
type scope_var = lident Mark.pos list
[@@deriving
visitors
{
variety = "map";
ancestors = ["Marked.pos_map"; "lident_map"];
ancestors = ["Mark.pos_map"; "lident_map"];
name = "scope_var_map";
},
visitors
{
variety = "iter";
ancestors = ["Marked.pos_iter"; "lident_iter"];
ancestors = ["Mark.pos_iter"; "lident_iter"];
name = "scope_var_iter";
}]
(** [foo.bar] in binding position: used to specify variables of subscopes *)
@ -81,7 +81,7 @@ type primitive_typ =
| Duration
| Text
| Date
| Named of path * uident Marked.pos
| Named of path * uident Mark.pos
[@@deriving
visitors
{
@ -98,18 +98,18 @@ type primitive_typ =
type base_typ_data =
| Primitive of primitive_typ
| Collection of base_typ_data Marked.pos
| Collection of base_typ_data Mark.pos
[@@deriving
visitors
{
variety = "map";
ancestors = ["Marked.pos_map"; "primitive_typ_map"];
ancestors = ["Mark.pos_map"; "primitive_typ_map"];
name = "base_typ_data_map";
},
visitors
{
variety = "iter";
ancestors = ["Marked.pos_iter"; "primitive_typ_iter"];
ancestors = ["Mark.pos_iter"; "primitive_typ_iter"];
name = "base_typ_data_iter";
}]
@ -131,8 +131,8 @@ type base_typ = Condition | Data of base_typ_data
}]
type func_typ = {
arg_typ : (lident Marked.pos * base_typ Marked.pos) list;
return_typ : base_typ Marked.pos;
arg_typ : (lident Mark.pos * base_typ Mark.pos) list;
return_typ : base_typ Mark.pos;
}
[@@deriving
visitors
@ -150,7 +150,7 @@ type func_typ = {
nude = true;
}]
type typ = naked_typ Marked.pos
type typ = naked_typ Mark.pos
and naked_typ = Base of base_typ | Func of func_typ
[@@deriving
@ -170,7 +170,7 @@ and naked_typ = Base of base_typ | Func of func_typ
}]
type struct_decl_field = {
struct_decl_field_name : lident Marked.pos;
struct_decl_field_name : lident Mark.pos;
struct_decl_field_typ : typ;
}
[@@deriving
@ -188,8 +188,8 @@ type struct_decl_field = {
}]
type struct_decl = {
struct_decl_name : uident Marked.pos;
struct_decl_fields : struct_decl_field Marked.pos list;
struct_decl_name : uident Mark.pos;
struct_decl_fields : struct_decl_field Mark.pos list;
}
[@@deriving
visitors
@ -206,7 +206,7 @@ type struct_decl = {
}]
type enum_decl_case = {
enum_decl_case_name : uident Marked.pos;
enum_decl_case_name : uident Mark.pos;
enum_decl_case_typ : typ option;
}
[@@deriving
@ -226,8 +226,8 @@ type enum_decl_case = {
}]
type enum_decl = {
enum_decl_name : uident Marked.pos;
enum_decl_cases : enum_decl_case Marked.pos list;
enum_decl_name : uident Mark.pos;
enum_decl_cases : enum_decl_case Mark.pos list;
}
[@@deriving
visitors
@ -246,19 +246,18 @@ type enum_decl = {
}]
type match_case_pattern =
(path * uident Marked.pos) Marked.pos list * lident Marked.pos option
(path * uident Mark.pos) Mark.pos list * lident Mark.pos option
[@@deriving
visitors
{
variety = "map";
ancestors = ["path_map"; "lident_map"; "uident_map"; "Marked.pos_map"];
ancestors = ["path_map"; "lident_map"; "uident_map"; "Mark.pos_map"];
name = "match_case_pattern_map";
},
visitors
{
variety = "iter";
ancestors =
["path_iter"; "lident_iter"; "uident_iter"; "Marked.pos_iter"];
ancestors = ["path_iter"; "lident_iter"; "uident_iter"; "Mark.pos_iter"];
name = "match_case_pattern_iter";
}]
@ -336,15 +335,11 @@ type literal_date = {
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["Marked.pos_map"];
name = "literal_date_map";
},
{ variety = "map"; ancestors = ["Mark.pos_map"]; name = "literal_date_map" },
visitors
{
variety = "iter";
ancestors = ["Marked.pos_iter"];
ancestors = ["Mark.pos_iter"];
name = "literal_date_iter";
}]
@ -369,7 +364,7 @@ type money_amount = {
visitors { variety = "iter"; name = "money_amount_iter"; nude = true }]
type literal =
| LNumber of literal_number Marked.pos * literal_unit Marked.pos option
| LNumber of literal_number Mark.pos * literal_unit Mark.pos option
| LBool of bool
| LMoneyAmount of money_amount
| LDate of literal_date
@ -400,10 +395,10 @@ type literal =
}]
type collection_op =
| Exists of { predicate : lident Marked.pos * expression }
| Forall of { predicate : lident Marked.pos * expression }
| Map of { f : lident Marked.pos * expression }
| Filter of { f : lident Marked.pos * expression }
| Exists of { predicate : lident Mark.pos * expression }
| Forall of { predicate : lident Mark.pos * expression }
| Map of { f : lident Mark.pos * expression }
| Filter of { f : lident Mark.pos * expression }
| AggregateSum of { typ : primitive_typ }
(* it would be nice to remove the need for specifying the type here like for
extremums, but we need an additionl overload for "neutral element for
@ -412,41 +407,39 @@ type collection_op =
| AggregateArgExtremum of {
max : bool;
default : expression;
f : lident Marked.pos * expression;
f : lident Mark.pos * expression;
}
and explicit_match_case = {
match_case_pattern : match_case_pattern Marked.pos;
match_case_pattern : match_case_pattern Mark.pos;
match_case_expr : expression;
}
and match_case = WildCard of expression | MatchCase of explicit_match_case
and match_cases = match_case Marked.pos list
and expression = naked_expression Marked.pos
and match_cases = match_case Mark.pos list
and expression = naked_expression Mark.pos
and naked_expression =
| Paren of expression
| MatchWith of expression * match_cases Marked.pos
| MatchWith of expression * match_cases Mark.pos
| IfThenElse of expression * expression * expression
| Binop of binop Marked.pos * expression * expression
| Unop of unop Marked.pos * expression
| Binop of binop Mark.pos * expression * expression
| Unop of unop Mark.pos * expression
| CollectionOp of collection_op * expression
| MemCollection of expression * expression
| TestMatchCase of expression * match_case_pattern Marked.pos
| TestMatchCase of expression * match_case_pattern Mark.pos
| FunCall of expression * expression list
| ScopeCall of
(path * uident Marked.pos) Marked.pos
* (lident Marked.pos * expression) list
| LetIn of lident Marked.pos * expression * expression
(path * uident Mark.pos) Mark.pos * (lident Mark.pos * expression) list
| LetIn of lident Mark.pos * expression * expression
| Builtin of builtin_expression
| Literal of literal
| EnumInject of (path * uident Marked.pos) Marked.pos * expression option
| EnumInject of (path * uident Mark.pos) Mark.pos * expression option
| StructLit of
(path * uident Marked.pos) Marked.pos
* (lident Marked.pos * expression) list
(path * uident Mark.pos) Mark.pos * (lident Mark.pos * expression) list
| ArrayLit of expression list
| Ident of path * lident Marked.pos
| Dotted of expression * (path * lident Marked.pos) Marked.pos
| Ident of path * lident Mark.pos
| Dotted of expression * (path * lident Mark.pos) Mark.pos
(** Dotted is for both struct field projection and sub-scope variables *)
[@@deriving
visitors
@ -481,30 +474,30 @@ and naked_expression =
type exception_to =
| NotAnException
| UnlabeledException
| ExceptionToLabel of lident Marked.pos
| ExceptionToLabel of lident Mark.pos
[@@deriving
visitors
{
variety = "map";
ancestors = ["lident_map"; "Marked.pos_map"];
ancestors = ["lident_map"; "Mark.pos_map"];
name = "exception_to_map";
},
visitors
{
variety = "iter";
ancestors = ["lident_iter"; "Marked.pos_iter"];
ancestors = ["lident_iter"; "Mark.pos_iter"];
name = "exception_to_iter";
}]
type rule = {
rule_label : lident Marked.pos option;
rule_label : lident Mark.pos option;
rule_exception_to : exception_to;
rule_parameter : lident Marked.pos list Marked.pos option;
rule_parameter : lident Mark.pos list Mark.pos option;
rule_condition : expression option;
rule_name : scope_var Marked.pos;
rule_name : scope_var Mark.pos;
rule_id : Shared_ast.RuleName.t; [@opaque]
rule_consequence : (bool[@opaque]) Marked.pos;
rule_state : lident Marked.pos option;
rule_consequence : (bool[@opaque]) Mark.pos;
rule_state : lident Mark.pos option;
}
[@@deriving
visitors
@ -521,14 +514,14 @@ type rule = {
}]
type definition = {
definition_label : lident Marked.pos option;
definition_label : lident Mark.pos option;
definition_exception_to : exception_to;
definition_name : scope_var Marked.pos;
definition_parameter : lident Marked.pos list Marked.pos option;
definition_name : scope_var Mark.pos;
definition_parameter : lident Mark.pos list Mark.pos option;
definition_condition : expression option;
definition_id : Shared_ast.RuleName.t; [@opaque]
definition_expr : expression;
definition_state : lident Marked.pos option;
definition_state : lident Mark.pos option;
}
[@@deriving
visitors
@ -550,9 +543,9 @@ type variation_typ = Increasing | Decreasing
visitors { variety = "iter"; name = "variation_typ_iter" }]
type meta_assertion =
| FixedBy of scope_var Marked.pos * lident Marked.pos
| FixedBy of scope_var Mark.pos * lident Mark.pos
| VariesWith of
scope_var Marked.pos * expression * variation_typ Marked.pos option
scope_var Mark.pos * expression * variation_typ Mark.pos option
[@@deriving
visitors
{
@ -586,7 +579,7 @@ type scope_use_item =
| Definition of definition
| Assertion of assertion
| MetaAssertion of meta_assertion
| DateRounding of variation_typ Marked.pos
| DateRounding of variation_typ Mark.pos
[@@deriving
visitors
{
@ -610,8 +603,8 @@ type scope_use_item =
type scope_use = {
scope_use_condition : expression option;
scope_use_name : uident Marked.pos;
scope_use_items : scope_use_item Marked.pos list;
scope_use_name : uident Mark.pos;
scope_use_items : scope_use_item Mark.pos list;
}
[@@deriving
visitors
@ -633,26 +626,26 @@ type io_input = Input | Context | Internal
visitors { variety = "iter"; name = "io_input_iter" }]
type scope_decl_context_io = {
scope_decl_context_io_input : io_input Marked.pos;
scope_decl_context_io_output : bool Marked.pos;
scope_decl_context_io_input : io_input Mark.pos;
scope_decl_context_io_output : bool Mark.pos;
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["io_input_map"; "Marked.pos_map"];
ancestors = ["io_input_map"; "Mark.pos_map"];
name = "scope_decl_context_io_map";
},
visitors
{
variety = "iter";
ancestors = ["io_input_iter"; "Marked.pos_iter"];
ancestors = ["io_input_iter"; "Mark.pos_iter"];
name = "scope_decl_context_io_iter";
}]
type scope_decl_context_scope = {
scope_decl_context_scope_name : lident Marked.pos;
scope_decl_context_scope_sub_scope : uident Marked.pos;
scope_decl_context_scope_name : lident Mark.pos;
scope_decl_context_scope_sub_scope : uident Mark.pos;
scope_decl_context_scope_attribute : scope_decl_context_io;
}
[@@deriving
@ -661,10 +654,7 @@ type scope_decl_context_scope = {
variety = "map";
ancestors =
[
"lident_map";
"uident_map";
"scope_decl_context_io_map";
"Marked.pos_map";
"lident_map"; "uident_map"; "scope_decl_context_io_map"; "Mark.pos_map";
];
name = "scope_decl_context_scope_map";
},
@ -676,18 +666,18 @@ type scope_decl_context_scope = {
"lident_iter";
"uident_iter";
"scope_decl_context_io_iter";
"Marked.pos_iter";
"Mark.pos_iter";
];
name = "scope_decl_context_scope_iter";
}]
type scope_decl_context_data = {
scope_decl_context_item_name : lident Marked.pos;
scope_decl_context_item_name : lident Mark.pos;
scope_decl_context_item_typ : typ;
scope_decl_context_item_parameters :
(lident Marked.pos * typ) list Marked.pos option;
(lident Mark.pos * typ) list Mark.pos option;
scope_decl_context_item_attribute : scope_decl_context_io;
scope_decl_context_item_states : lident Marked.pos list;
scope_decl_context_item_states : lident Mark.pos list;
}
[@@deriving
visitors
@ -723,8 +713,8 @@ type scope_decl_context_item =
}]
type scope_decl = {
scope_decl_name : uident Marked.pos;
scope_decl_context : scope_decl_context_item Marked.pos list;
scope_decl_name : uident Mark.pos;
scope_decl_context : scope_decl_context_item Mark.pos list;
}
[@@deriving
visitors
@ -741,9 +731,8 @@ type scope_decl = {
}]
type top_def = {
topdef_name : lident Marked.pos;
topdef_args :
(lident Marked.pos * base_typ Marked.pos) list Marked.pos option;
topdef_name : lident Mark.pos;
topdef_args : (lident Mark.pos * base_typ Mark.pos) list Mark.pos option;
(** Empty list if this is not a function *)
topdef_type : typ;
topdef_expr : expression;
@ -796,7 +785,7 @@ type code_item =
name = "code_item_iter";
}]
type code_block = code_item Marked.pos list
type code_block = code_item Mark.pos list
[@@deriving
visitors
{ variety = "map"; ancestors = ["code_item_map"]; name = "code_block_map" },
@ -807,56 +796,44 @@ type code_block = code_item Marked.pos list
name = "code_block_iter";
}]
type source_repr = (string[@opaque]) Marked.pos
type source_repr = (string[@opaque]) Mark.pos
[@@deriving
visitors
{
variety = "map";
ancestors = ["Marked.pos_map"];
name = "source_repr_map";
},
{ variety = "map"; ancestors = ["Mark.pos_map"]; name = "source_repr_map" },
visitors
{
variety = "iter";
ancestors = ["Marked.pos_iter"];
ancestors = ["Mark.pos_iter"];
name = "source_repr_iter";
}]
type law_heading = {
law_heading_name : (string[@opaque]) Marked.pos;
law_heading_name : (string[@opaque]) Mark.pos;
law_heading_id : (string[@opaque]) option;
law_heading_is_archive : bool; [@opaque]
law_heading_precedence : (int[@opaque]);
}
[@@deriving
visitors
{
variety = "map";
ancestors = ["Marked.pos_map"];
name = "law_heading_map";
},
{ variety = "map"; ancestors = ["Mark.pos_map"]; name = "law_heading_map" },
visitors
{
variety = "iter";
ancestors = ["Marked.pos_iter"];
ancestors = ["Mark.pos_iter"];
name = "law_heading_iter";
}]
type law_include =
| PdfFile of (string[@opaque]) Marked.pos * (int[@opaque]) option
| CatalaFile of (string[@opaque]) Marked.pos
| LegislativeText of (string[@opaque]) Marked.pos
| PdfFile of (string[@opaque]) Mark.pos * (int[@opaque]) option
| CatalaFile of (string[@opaque]) Mark.pos
| LegislativeText of (string[@opaque]) Mark.pos
[@@deriving
visitors
{
variety = "map";
ancestors = ["Marked.pos_map"];
name = "law_include_map";
},
{ variety = "map"; ancestors = ["Mark.pos_map"]; name = "law_include_map" },
visitors
{
variety = "iter";
ancestors = ["Marked.pos_iter"];
ancestors = ["Mark.pos_iter"];
name = "law_include_iter";
}]
@ -911,9 +888,7 @@ type source_file = law_structure list
(** Translates a {!type: rule} into the corresponding {!type: definition} *)
let rule_to_def (rule : rule) : definition =
let consequence_expr =
Literal (LBool (Marked.unmark rule.rule_consequence))
in
let consequence_expr = Literal (LBool (Mark.remove rule.rule_consequence)) in
{
definition_label = rule.rule_label;
definition_exception_to = rule.rule_exception_to;
@ -921,14 +896,14 @@ let rule_to_def (rule : rule) : definition =
definition_parameter = rule.rule_parameter;
definition_condition = rule.rule_condition;
definition_id = rule.rule_id;
definition_expr = consequence_expr, Marked.get_mark rule.rule_consequence;
definition_expr = consequence_expr, Mark.get rule.rule_consequence;
definition_state = rule.rule_state;
}
let type_from_args
(args : (lident Marked.pos * base_typ Marked.pos) list Marked.pos option)
(return_typ : base_typ Marked.pos) : typ =
(args : (lident Mark.pos * base_typ Mark.pos) list Mark.pos option)
(return_typ : base_typ Mark.pos) : typ =
match args with
| None -> Marked.map_under_mark (fun r -> Base r) return_typ
| None -> Mark.map (fun r -> Base r) return_typ
| Some (arg_typ, _) ->
Marked.mark (Marked.get_mark return_typ) (Func { arg_typ; return_typ })
Mark.add (Mark.get return_typ) (Func { arg_typ; return_typ })

4
compiler/surface/fill_positions.ml
View File

@ -22,13 +22,13 @@ let fill_pos_with_legislative_info (p : Ast.program) : Ast.program =
inherit [_] Ast.program_map as super
method! visit_pos f env x =
f env (Marked.unmark x), Pos.overwrite_law_info (Marked.get_mark x) env
f env (Mark.remove x), Pos.overwrite_law_info (Mark.get x) env
method! visit_LawHeading
(env : string list)
(heading : Ast.law_heading)
(children : Ast.law_structure list) =
let env = Marked.unmark heading.law_heading_name :: env in
let env = Mark.remove heading.law_heading_name :: env in
Ast.LawHeading
( super#visit_law_heading env heading,
List.map (fun child -> super#visit_law_structure env child) children

58
compiler/surface/parser.mly
View File

@ -47,42 +47,42 @@ end>
(* Types of all rules, in order. Without this, Menhir type errors are nearly
impossible to debug because of inlining *)
%type<Ast.uident Marked.pos> addpos(UIDENT)
%type<Ast.uident Mark.pos> addpos(UIDENT)
%type<Pos.t> pos(CONDITION)
%type<Ast.primitive_typ> primitive_typ
%type<Ast.base_typ_data> typ_data
%type<Ast.base_typ> typ
%type<Ast.uident Marked.pos> uident
%type<Ast.lident Marked.pos> lident
%type<Ast.uident Mark.pos> uident
%type<Ast.lident Mark.pos> lident
%type<Ast.scope_var> scope_var
%type<Ast.path * Ast.uident Marked.pos> quident
%type<Ast.path * Ast.lident Marked.pos> qlident
%type<Ast.path * Ast.uident Mark.pos> quident
%type<Ast.path * Ast.lident Mark.pos> qlident
%type<Ast.expression> expression
%type<Ast.naked_expression> naked_expression
%type<Ast.lident Marked.pos * expression> struct_content_field
%type<Ast.lident Mark.pos * expression> struct_content_field
%type<Ast.naked_expression> struct_or_enum_inject
%type<Ast.literal_number> num_literal
%type<Ast.literal_unit> unit_literal
%type<Ast.literal> literal
%type<(Ast.lident Marked.pos * expression) list> scope_call_args
%type<(Ast.lident Mark.pos * expression) list> scope_call_args
%type<bool> minmax
%type<Ast.unop> unop
%type<Ast.binop> binop
%type<Ast.match_case_pattern> constructor_binding
%type<Ast.match_case> match_arm
%type<Ast.expression> condition_consequence
%type<Ast.scope_var Marked.pos * Ast.lident Marked.pos list Marked.pos option> rule_expr
%type<Ast.scope_var Mark.pos * Ast.lident Mark.pos list Mark.pos option> rule_expr
%type<bool> rule_consequence
%type<Ast.rule> rule
%type<Ast.lident Marked.pos list> definition_parameters
%type<Ast.lident Marked.pos> label
%type<Ast.lident Marked.pos> state
%type<Ast.lident Mark.pos list> definition_parameters
%type<Ast.lident Mark.pos> label
%type<Ast.lident Mark.pos> state
%type<Ast.exception_to> exception_to
%type<Ast.definition> definition
%type<Ast.variation_typ> variation_type
%type<Ast.scope_use_item> assertion
%type<Ast.scope_use_item Marked.pos> scope_item
%type<Ast.lident Marked.pos * Ast.base_typ Marked.pos> struct_scope_base
%type<Ast.scope_use_item Mark.pos> scope_item
%type<Ast.lident Mark.pos * Ast.base_typ Mark.pos> struct_scope_base
%type<Ast.struct_decl_field> struct_scope
%type<Ast.io_input> scope_decl_item_attribute_input
%type<bool> scope_decl_item_attribute_output
@ -91,7 +91,7 @@ end>
%type<Ast.enum_decl_case> enum_decl_line
%type<Ast.code_item> code_item
%type<Ast.code_block> code
%type<Ast.code_block * string Marked.pos> metadata_block
%type<Ast.code_block * string Mark.pos> metadata_block
%type<Ast.law_heading> law_heading
%type<string> law_text
%type<Ast.law_structure> source_file_item
@ -157,7 +157,7 @@ let expression :=
let naked_expression ==
| id = addpos(LIDENT) ; {
match Localisation.lex_builtin (Marked.unmark id) with
match Localisation.lex_builtin (Mark.remove id) with
| Some b -> Builtin b
| None -> Ident ([], id)
}
@ -204,7 +204,7 @@ let naked_expression ==
} %prec apply
| SUM ; typ = addpos(primitive_typ) ;
OF ; coll = expression ; {
CollectionOp (AggregateSum { typ = Marked.unmark typ }, coll)
CollectionOp (AggregateSum { typ = Mark.remove typ }, coll)
} %prec apply
| f = expression ;
FOR ; i = lident ;
@ -392,14 +392,14 @@ let rule :=
cond = option(condition_consequence) ;
consequence = addpos(rule_consequence) ; {
let (name, params_applied) = name_and_param in
let cons : bool Marked.pos = consequence in
let cons : bool Mark.pos = consequence in
let rule_exception = match except with
| None -> NotAnException
| Some x -> Marked.unmark x
| Some x -> Mark.remove x
in
let pos_start =
match label with Some l -> Marked.get_mark l
| None -> match except with Some e -> Marked.get_mark e
match label with Some l -> Mark.get l
| None -> match except with Some e -> Mark.get e
| None -> pos_rule
in
{
@ -409,8 +409,8 @@ let rule :=
rule_condition = cond;
rule_name = name;
rule_id = Shared_ast.RuleName.fresh
(String.concat "." (List.map (fun i -> Marked.unmark i) (Marked.unmark name)),
Pos.join pos_start (Marked.get_mark name));
(String.concat "." (List.map (fun i -> Mark.remove i) (Mark.remove name)),
Pos.join pos_start (Mark.get name));
rule_consequence = cons;
rule_state = state;
}
@ -460,8 +460,8 @@ let definition :=
definition_condition = cond;
definition_id =
Shared_ast.RuleName.fresh
(String.concat "." (List.map (fun i -> Marked.unmark i) (Marked.unmark name)),
Pos.join pos_start (Marked.get_mark name));
(String.concat "." (List.map (fun i -> Mark.remove i) (Mark.remove name)),
Pos.join pos_start (Mark.get name));
definition_expr = e;
definition_state = state;
}
@ -490,10 +490,10 @@ let assertion :=
let scope_item :=
| r = rule ; {
Rule r, Marked.get_mark (Shared_ast.RuleName.get_info r.rule_id)
Rule r, Mark.get (Shared_ast.RuleName.get_info r.rule_id)
}
| d = definition ; {
Definition d, Marked.get_mark (Shared_ast.RuleName.get_info d.definition_id)
Definition d, Mark.get (Shared_ast.RuleName.get_info d.definition_id)
}
| ASSERTION ; contents = addpos(assertion) ; <>
| DATE ; i = LIDENT ; v = addpos(variation_type) ;
@ -501,7 +501,7 @@ let scope_item :=
(* Round is a builtin, we need to check which one it is *)
match Localisation.lex_builtin i with
| Some Round ->
DateRounding(v), Marked.get_mark v
DateRounding(v), Mark.get v
| _ ->
Errors.raise_spanned_error
(Pos.from_lpos $loc(i))
@ -567,7 +567,7 @@ let scope_decl_item :=
scope_decl_context_item_attribute = attr;
scope_decl_context_item_parameters =
Option.map
(Marked.map_under_mark
(Mark.map
(List.map (fun (lbl, (base_t, m)) -> lbl, (Base base_t, m))))
args_typ;
scope_decl_context_item_typ = type_from_args args_typ t;
@ -594,7 +594,7 @@ let scope_decl_item :=
scope_decl_context_item_attribute = attr;
scope_decl_context_item_parameters =
Option.map
(Marked.map_under_mark
(Mark.map
(List.map (fun (lbl, (base_t, m)) -> lbl, (Base base_t, m))))
args;
scope_decl_context_item_typ =

4
compiler/surface/parser_driver.ml
View File

@ -305,9 +305,7 @@ and expand_includes
match command with
| Ast.LawInclude (Ast.CatalaFile sub_source) ->
let source_dir = Filename.dirname source_file in
let sub_source =
Filename.concat source_dir (Marked.unmark sub_source)
in
let sub_source = Filename.concat source_dir (Mark.remove sub_source) in
let includ_program = parse_source_file (FileName sub_source) language in
{
Ast.program_source_files =

3
compiler/surface/print.ml
View File

@ -31,5 +31,4 @@ let format_primitive_typ (fmt : Format.formatter) (t : primitive_typ) : unit =
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.pp_print_char fmt '.')
(fun fmt (uid, _pos) -> Format.pp_print_string fmt uid))
path
(Marked.unmark constructor)
path (Mark.remove constructor)

62
compiler/verification/conditions.ml
View File

@ -113,7 +113,7 @@ let half_product (l1 : 'a list) (l2 : 'b list) : ('a * 'b) list =
and have a clean verification condition generator that only runs on [e1] *)
let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : typed expr) :
typed expr =
match Marked.unmark e with
match Mark.remove e with
| EErrorOnEmpty
( EDefault
{
@ -132,7 +132,7 @@ let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : typed expr) :
| EAbs { binder; _ } -> (
(* context scope variables *)
let _, body = Bindlib.unmbind binder in
match Marked.unmark body with
match Mark.remove body with
| EErrorOnEmpty e -> e
| _ ->
Errors.raise_spanned_error (Expr.pos e)
@ -157,7 +157,7 @@ let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : typed expr) :
expression. *)
let rec generate_vc_must_not_return_empty (ctx : ctx) (e : typed expr) :
vc_return =
match Marked.unmark e with
match Mark.remove e with
| EAbs { binder; _ } ->
(* Hot take: for a function never to return an empty error when called, it
has to do so whatever its input. So we universally quantify over the
@ -189,20 +189,20 @@ let rec generate_vc_must_not_return_empty (ctx : ctx) (e : typed expr) :
translation preventing any default terms to appear in
justifications.*)
etrue = vc_just_expr;
efalse = ELit (LBool false), Marked.get_mark e;
efalse = ELit (LBool false), Mark.get e;
},
Marked.get_mark e ));
Mark.get e ));
]
(Marked.get_mark e);
(Mark.get e);
])
(Marked.get_mark e)
| EEmptyError -> Marked.same_mark_as (ELit (LBool false)) e
(Mark.get e)
| EEmptyError -> Mark.copy e (ELit (LBool false))
| EVar _
(* Per default calculus semantics, you cannot call a function with an argument
that evaluates to the empty error. Thus, all variable evaluate to
non-empty-error terms. *)
| ELit _ | EOp _ ->
Marked.same_mark_as (ELit (LBool true)) e
Mark.copy e (ELit (LBool true))
| EApp { f; args } ->
(* Invariant: For the [EApp] case, we assume here that function calls never
return empty error, which implies all functions have been checked never
@ -212,11 +212,11 @@ let rec generate_vc_must_not_return_empty (ctx : ctx) (e : typed expr) :
:: List.flatten
(List.map
(fun arg ->
match Marked.unmark arg with
match Mark.remove arg with
| EStruct { fields; _ } ->
List.map
(fun (_, field) ->
match Marked.unmark field with
match Mark.remove field with
| EAbs { binder; tys = [(TLit TUnit, _)] } -> (
(* Invariant: when calling a function with a thunked
emptyerror, this means we're in a direct scope call
@ -226,9 +226,8 @@ let rec generate_vc_must_not_return_empty (ctx : ctx) (e : typed expr) :
never return empty error so the thunked emptyerror
can be ignored *)
let _vars, body = Bindlib.unmbind binder in
match Marked.unmark body with
| EEmptyError ->
Marked.same_mark_as (ELit (LBool true)) field
match Mark.remove body with
| EEmptyError -> Mark.copy field (ELit (LBool true))
| _ ->
(* same as basic [EAbs case]*)
generate_vc_must_not_return_empty ctx field)
@ -236,13 +235,13 @@ let rec generate_vc_must_not_return_empty (ctx : ctx) (e : typed expr) :
(StructField.Map.bindings fields)
| _ -> [generate_vc_must_not_return_empty ctx arg])
args))
(Marked.get_mark e)
(Mark.get e)
| _ ->
conjunction
(Expr.shallow_fold
(fun e acc -> generate_vc_must_not_return_empty ctx e :: acc)
e [])
(Marked.get_mark e)
(Mark.get e)
(** [generate_vc_must_not_return_conflict e] returns the dcalc boolean
expression [b] such that if [b] is true, then [e] will never return a
@ -252,11 +251,11 @@ let rec generate_vc_must_not_return_conflict (ctx : ctx) (e : typed expr) :
vc_return =
(* See the code of [generate_vc_must_not_return_empty] for a list of
invariants on which this function relies on. *)
match Marked.unmark e with
match Mark.remove e with
| EAbs { binder; _ } ->
let _vars, body = Bindlib.unmbind binder in
(generate_vc_must_not_return_conflict ctx) body
| EVar _ | ELit _ | EOp _ -> Marked.same_mark_as (ELit (LBool true)) e
| EVar _ | ELit _ | EOp _ -> Mark.copy e (ELit (LBool true))
| EDefault { excepts; just; cons } ->
(* <e1 ... en | ejust :- econs > never returns conflict if and only if: -
neither e1 nor ... nor en nor ejust nor econs return conflict - there is
@ -271,24 +270,24 @@ let rec generate_vc_must_not_return_conflict (ctx : ctx) (e : typed expr) :
generate_vc_must_not_return_empty ctx e1;
generate_vc_must_not_return_empty ctx e2;
]
(Marked.get_mark e))
(Mark.get e))
(half_product excepts excepts))
(Marked.get_mark e))
(Marked.get_mark e)
(Mark.get e))
(Mark.get e)
in
let others =
List.map
(generate_vc_must_not_return_conflict ctx)
(just :: cons :: excepts)
in
let out = conjunction (quadratic :: others) (Marked.get_mark e) in
let out = conjunction (quadratic :: others) (Mark.get e) in
out
| _ ->
conjunction
(Expr.shallow_fold
(fun e acc -> generate_vc_must_not_return_conflict ctx e :: acc)
e [])
(Marked.get_mark e)
(Mark.get e)
(** {1 Interface}*)
@ -302,10 +301,10 @@ type verification_condition = {
assertion *)
vc_asserts : typed expr;
vc_scope : ScopeName.t;
vc_variable : typed expr Var.t Marked.pos;
vc_variable : typed expr Var.t Mark.pos;
}
let trivial_assert e = Marked.same_mark_as (ELit (LBool true)) e
let trivial_assert e = Mark.copy e (ELit (LBool true))
let rec generate_verification_conditions_scope_body_expr
(ctx : ctx)
@ -323,7 +322,7 @@ let rec generate_verification_conditions_scope_body_expr
let e =
Expr.unbox (Expr.remove_logging_calls scope_let.scope_let_expr)
in
match Marked.unmark e with
match Mark.remove e with
| EAssert e ->
let e = match_and_ignore_outer_reentrant_default ctx e in
ctx, [], [e]
@ -355,7 +354,7 @@ let rec generate_verification_conditions_scope_body_expr
let vc_list =
[
{
vc_guard = Marked.same_mark_as (Marked.unmark vc_confl) e;
vc_guard = Mark.copy e (Mark.remove vc_confl);
vc_kind = NoOverlappingExceptions;
(* Placeholder until we add all assertions in scope once
* we finished traversing it *)
@ -376,7 +375,7 @@ let rec generate_verification_conditions_scope_body_expr
else vc_empty
in
{
vc_guard = Marked.same_mark_as (Marked.unmark vc_empty) e;
vc_guard = Mark.copy e (Mark.remove vc_empty);
vc_kind = NoEmptyError;
vc_asserts = trivial_assert e;
vc_scope = ctx.current_scope_name;
@ -440,10 +439,7 @@ let generate_verification_conditions_code_items
let combined_assert =
conjunction_exprs asserts
(Typed
{
pos = Pos.no_pos;
ty = Marked.mark Pos.no_pos (TLit TBool);
})
{ pos = Pos.no_pos; ty = Mark.add Pos.no_pos (TLit TBool) })
in
List.map (fun vc -> { vc with vc_asserts = combined_assert }) vcs
else []
@ -463,7 +459,7 @@ let generate_verification_conditions (p : 'm program) (s : ScopeName.t option) :
let to_str vc =
Format.asprintf "%s.%s"
(Format.asprintf "%a" ScopeName.format_t vc.vc_scope)
(Bindlib.name_of (Marked.unmark vc.vc_variable))
(Bindlib.name_of (Mark.remove vc.vc_variable))
in
String.compare (to_str vc1) (to_str vc2))
vcs

2
compiler/verification/conditions.mli
View File

@ -36,7 +36,7 @@ type verification_condition = {
(** A conjunction of all assertions in scope of this VC. * This expression
should have type [bool] *)
vc_scope : ScopeName.t;
vc_variable : typed Dcalc.Ast.expr Var.t Marked.pos;
vc_variable : typed Dcalc.Ast.expr Var.t Mark.pos;
}
val generate_verification_conditions :

10
compiler/verification/io.ml
View File

@ -102,15 +102,15 @@ module MakeBackendIO (B : Backend) = struct
Format.asprintf "%s This variable might return an empty error:\n%s"
(Cli.with_style [ANSITerminal.yellow] "[%s.%s]"
(Format.asprintf "%a" ScopeName.format_t vc.vc_scope)
(Bindlib.name_of (Marked.unmark vc.vc_variable)))
(Pos.retrieve_loc_text (Marked.get_mark vc.vc_variable))
(Bindlib.name_of (Mark.remove vc.vc_variable)))
(Pos.retrieve_loc_text (Mark.get vc.vc_variable))
| Conditions.NoOverlappingExceptions ->
Format.asprintf
"%s At least two exceptions overlap for this variable:\n%s"
(Cli.with_style [ANSITerminal.yellow] "[%s.%s]"
(Format.asprintf "%a" ScopeName.format_t vc.vc_scope)
(Bindlib.name_of (Marked.unmark vc.vc_variable)))
(Pos.retrieve_loc_text (Marked.get_mark vc.vc_variable))
(Bindlib.name_of (Mark.remove vc.vc_variable)))
(Pos.retrieve_loc_text (Mark.get vc.vc_variable))
in
let counterexample : string option =
if !Cli.disable_counterexamples then
@ -170,7 +170,7 @@ module MakeBackendIO (B : Backend) = struct
Cli.error_print "%s The translation to Z3 failed:\n%s"
(Cli.with_style [ANSITerminal.yellow] "[%s.%s]"
(Format.asprintf "%a" ScopeName.format_t vc.vc_scope)
(Bindlib.name_of (Marked.unmark vc.vc_variable)))
(Bindlib.name_of (Mark.remove vc.vc_variable)))
msg;
false
end

46
compiler/verification/z3backend.real.ml
View File

@ -159,12 +159,12 @@ let rec print_z3model_expr (ctx : context) (ty : typ) (e : Expr.expr) : string =
| TDuration -> Format.asprintf "%s days" (Expr.to_string e)
in
match Marked.unmark ty with
match Mark.remove ty with
| TLit ty -> print_lit ty
| TStruct name ->
let s = StructName.Map.find name ctx.ctx_decl.ctx_structs in
let get_fieldname (fn : StructField.t) : string =
Marked.unmark (StructField.get_info fn)
Mark.remove (StructField.get_info fn)
in
let fields =
List.map2
@ -178,7 +178,7 @@ let rec print_z3model_expr (ctx : context) (ty : typ) (e : Expr.expr) : string =
let fields_str = String.concat " " fields in
Format.asprintf "%s { %s }"
(Marked.unmark (StructName.get_info name))
(Mark.remove (StructName.get_info name))
fields_str
| TTuple _ ->
failwith "[Z3 model]: Pretty-printing of unnamed structs not supported"
@ -193,7 +193,7 @@ let rec print_z3model_expr (ctx : context) (ty : typ) (e : Expr.expr) : string =
List.find
(fun (ctr, _) ->
(* FIXME: don't match on strings *)
String.equal fd_name (Marked.unmark (EnumConstructor.get_info ctr)))
String.equal fd_name (Mark.remove (EnumConstructor.get_info ctr)))
(EnumConstructor.Map.bindings enum_ctrs)
in
@ -289,8 +289,8 @@ and find_or_create_enum (ctx : context) (enum : EnumName.t) :
(* Creates a Z3 constructor corresponding to the Catala constructor [c] *)
let create_constructor (name : EnumConstructor.t) (ty : typ) (ctx : context) :
context * Datatype.Constructor.constructor =
let name = Marked.unmark (EnumConstructor.get_info name) in
let ctx, arg_z3_ty = translate_typ ctx (Marked.unmark ty) in
let name = Mark.remove (EnumConstructor.get_info name) in
let ctx, arg_z3_ty = translate_typ ctx (Mark.remove ty) in
(* The mk_constructor_s Z3 function is not so well documented. From my
understanding, its argument are: - a string corresponding to the name of
@ -324,7 +324,7 @@ and find_or_create_enum (ctx : context) (enum : EnumName.t) :
in
let z3_enum =
Datatype.mk_sort_s ctx.ctx_z3
(Marked.unmark (EnumName.get_info enum))
(Mark.remove (EnumName.get_info enum))
(List.rev z3_ctrs)
in
add_z3enum enum z3_enum ctx, z3_enum
@ -338,19 +338,19 @@ and find_or_create_struct (ctx : context) (s : StructName.t) :
match StructName.Map.find_opt s ctx.ctx_z3structs with
| Some s -> ctx, s
| None ->
let s_name = Marked.unmark (StructName.get_info s) in
let s_name = Mark.remove (StructName.get_info s) in
let fields = StructName.Map.find s ctx.ctx_decl.ctx_structs in
let z3_fieldnames =
List.map
(fun f ->
Marked.unmark (StructField.get_info (fst f))
Mark.remove (StructField.get_info (fst f))
|> Symbol.mk_string ctx.ctx_z3)
(StructField.Map.bindings fields)
in
let ctx, z3_fieldtypes_rev =
StructField.Map.fold
(fun _ ty (ctx, ftypes) ->
let ctx, ftype = translate_typ ctx (Marked.unmark ty) in
let ctx, ftype = translate_typ ctx (Mark.remove ty) in
ctx, ftype :: ftypes)
fields (ctx, [])
in
@ -403,12 +403,12 @@ let find_or_create_funcdecl (ctx : context) (v : typed expr Var.t) (ty : typ) :
match Var.Map.find_opt v ctx.ctx_funcdecl with
| Some fd -> ctx, fd
| None -> (
match Marked.unmark ty with
match Mark.remove ty with
| TArrow (t1, t2) ->
let ctx, z3_t1 =
List.fold_left_map translate_typ ctx (List.map Marked.unmark t1)
List.fold_left_map translate_typ ctx (List.map Mark.remove t1)
in
let ctx, z3_t2 = translate_typ ctx (Marked.unmark t2) in
let ctx, z3_t2 = translate_typ ctx (Mark.remove t2) in
let name = unique_name v in
let fd = FuncDecl.mk_func_decl_s ctx.ctx_z3 name z3_t1 z3_t2 in
let ctx = add_funcdecl v fd ctx in
@ -611,7 +611,7 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
(ctx : context)
(e : 'm expr * FuncDecl.func_decl list) : context * Expr.expr =
let e, accessors = e in
match Marked.unmark e with
match Mark.remove e with
| EAbs { binder; _ } ->
(* Create a fresh Catala variable to substitue and obtain the body *)
let fresh_v = Var.make "arm!tmp" in
@ -630,18 +630,18 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
| _ -> failwith "[Z3 encoding] : Arms branches inside VCs should be lambdas"
in
match Marked.unmark vc with
match Mark.remove vc with
| EVar v -> (
match Var.Map.find_opt v ctx.ctx_z3matchsubsts with
| None ->
(* We are in the standard case, where this is a true Catala variable *)
let (Typed { ty = t; _ }) = Marked.get_mark vc in
let (Typed { ty = t; _ }) = Mark.get vc in
let name = unique_name v in
let ctx = add_z3var name v t ctx in
let ctx, ty = translate_typ ctx (Marked.unmark t) in
let ctx, ty = translate_typ ctx (Mark.remove t) in
let z3_var = Expr.mk_const_s ctx.ctx_z3 name ty in
let ctx =
match Marked.unmark t with
match Mark.remove t with
(* If we are creating a new array, we need to log that its length is
greater than 0 *)
| TArray _ ->
@ -708,8 +708,8 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
will be fresh, and thus will not clash in Z3 *)
let fresh_v = Var.make "z3!match_tmp" in
let name = unique_name fresh_v in
let (Typed { ty = match_ty; _ }) = Marked.get_mark vc in
let ctx, z3_ty = translate_typ ctx (Marked.unmark match_ty) in
let (Typed { ty = match_ty; _ }) = Mark.get vc in
let ctx, z3_ty = translate_typ ctx (Mark.remove match_ty) in
let z3_var = Expr.mk_const_s ctx.ctx_z3 name z3_ty in
let ctx, z3_enum = find_or_create_enum ctx enum in
@ -740,10 +740,10 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
| ELit l -> ctx, translate_lit ctx l
| EAbs _ -> failwith "[Z3 encoding] EAbs unsupported"
| EApp { f = head; args } -> (
match Marked.unmark head with
match Mark.remove head with
| EOp { op; _ } -> translate_op ctx op args
| EVar v ->
let (Typed { ty = f_ty; _ }) = Marked.get_mark head in
let (Typed { ty = f_ty; _ }) = Mark.get head in
let ctx, fd = find_or_create_funcdecl ctx v f_ty in
(* Fold_right to preserve the order of the arguments: The head argument is
appended at the head *)
@ -761,7 +761,7 @@ and translate_expr (ctx : context) (vc : typed expr) : context * Expr.expr =
failwith "[Z3 encoding] EAbs not supported beyond let_in"
else
let arg = List.hd args in
let expr = Bindlib.msubst binder [| Marked.unmark arg |] in
let expr = Bindlib.msubst binder [| Mark.remove arg |] in
translate_expr ctx expr
| _ ->
failwith

4
french_law/catala_legifrance/catala_legifrance.ml
View File

@ -53,9 +53,9 @@ let check_article_expiration
Cli.warning_print
"%s %s has expired! Its expiration date is %s according to \
LégiFrance.%s"
(Marked.unmark law_heading.Surface.Ast.law_heading_name)
(Mark.remove law_heading.Surface.Ast.law_heading_name)
(Pos.to_string
(Marked.get_mark law_heading.Surface.Ast.law_heading_name))
(Mark.get law_heading.Surface.Ast.law_heading_name))
(Date.print_tm legifrance_expiration_date)
(match new_version with
| None -> ""