From fc531777c06643bd1cdbac8c35422e6d82d58b78 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Wed, 17 May 2023 15:44:57 +0200 Subject: [PATCH] Rework and normalise the `Marked` interface 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. --- compiler/catala_utils/{marked.ml => mark.ml} | 54 +++-- .../catala_utils/{marked.mli => mark.mli} | 49 ++-- compiler/catala_utils/uid.ml | 6 +- compiler/catala_utils/uid.mli | 2 +- compiler/dcalc/from_scopelang.ml | 203 ++++++++--------- compiler/dcalc/invariants.ml | 18 +- compiler/desugared/ast.ml | 44 ++-- compiler/desugared/ast.mli | 26 +-- compiler/desugared/dependency.ml | 13 +- compiler/desugared/from_surface.ml | 204 ++++++++--------- compiler/desugared/linting.ml | 12 +- compiler/desugared/name_resolution.ml | 168 +++++++------- compiler/desugared/name_resolution.mli | 22 +- compiler/lcalc/closure_conversion.ml | 31 ++- compiler/lcalc/compile_with_exceptions.ml | 16 +- compiler/lcalc/compile_without_exceptions.ml | 25 +-- compiler/lcalc/to_ocaml.ml | 26 +-- compiler/lcalc/to_ocaml.mli | 2 +- compiler/literate/html.ml | 25 +-- compiler/literate/latex.ml | 18 +- compiler/plugins/api_web.ml | 16 +- compiler/plugins/json_schema.ml | 8 +- compiler/plugins/lazy_interp.ml | 2 +- compiler/scalc/ast.ml | 16 +- compiler/scalc/from_lcalc.ml | 47 ++-- compiler/scalc/print.ml | 20 +- compiler/scalc/to_python.ml | 50 ++--- compiler/scopelang/ast.ml | 19 +- compiler/scopelang/ast.mli | 6 +- compiler/scopelang/dependency.ml | 24 +- compiler/scopelang/from_desugared.ml | 87 ++++---- compiler/scopelang/print.ml | 12 +- compiler/shared_ast/definitions.ml | 14 +- compiler/shared_ast/expr.ml | 86 ++++--- compiler/shared_ast/expr.mli | 20 +- compiler/shared_ast/interpreter.ml | 91 ++++---- compiler/shared_ast/operator.ml | 17 +- compiler/shared_ast/operator.mli | 8 +- compiler/shared_ast/optimizations.ml | 52 ++--- compiler/shared_ast/print.ml | 20 +- compiler/shared_ast/scope.ml | 17 +- compiler/shared_ast/type.ml | 6 +- compiler/shared_ast/typing.ml | 66 +++--- compiler/surface/ast.ml | 211 ++++++++---------- compiler/surface/fill_positions.ml | 4 +- compiler/surface/parser.mly | 58 ++--- compiler/surface/parser_driver.ml | 4 +- compiler/surface/print.ml | 3 +- compiler/verification/conditions.ml | 62 +++-- compiler/verification/conditions.mli | 2 +- compiler/verification/io.ml | 10 +- compiler/verification/z3backend.real.ml | 46 ++-- .../catala_legifrance/catala_legifrance.ml | 4 +- 53 files changed, 980 insertions(+), 1092 deletions(-) rename compiler/catala_utils/{marked.ml => mark.ml} (50%) rename compiler/catala_utils/{marked.mli => mark.mli} (51%) diff --git a/compiler/catala_utils/marked.ml b/compiler/catala_utils/mark.ml similarity index 50% rename from compiler/catala_utils/marked.ml rename to compiler/catala_utils/mark.ml index 0b7db959..e26d2407 100644 --- a/compiler/catala_utils/marked.ml +++ b/compiler/catala_utils/mark.ml @@ -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 diff --git a/compiler/catala_utils/marked.mli b/compiler/catala_utils/mark.mli similarity index 51% rename from compiler/catala_utils/marked.mli rename to compiler/catala_utils/mark.mli index 8f2e08b4..154e1239 100644 --- a/compiler/catala_utils/marked.mli +++ b/compiler/catala_utils/mark.mli @@ -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 diff --git a/compiler/catala_utils/uid.ml b/compiler/catala_utils/uid.ml index 51d8f107..8fec3821 100644 --- a/compiler/catala_utils/uid.ml +++ b/compiler/catala_utils/uid.ml @@ -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) () diff --git a/compiler/catala_utils/uid.mli b/compiler/catala_utils/uid.mli index 62ca76ef..8425634f 100644 --- a/compiler/catala_utils/uid.mli +++ b/compiler/catala_utils/uid.mli @@ -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. *) diff --git a/compiler/dcalc/from_scopelang.ml b/compiler/dcalc/from_scopelang.ml index 254a4fd0..2a8ee43f 100644 --- a/compiler/dcalc/from_scopelang.ml +++ b/compiler/dcalc/from_scopelang.ml @@ -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 { diff --git a/compiler/dcalc/invariants.ml b/compiler/dcalc/invariants.ml index f47a86d3..1769c6a9 100644 --- a/compiler/dcalc/invariants.ml +++ b/compiler/dcalc/invariants.ml @@ -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 diff --git a/compiler/desugared/ast.ml b/compiler/desugared/ast.ml index 0b29bc8b..5f22f281 100644 --- a/compiler/desugared/ast.ml +++ b/compiler/desugared/ast.ml @@ -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 diff --git a/compiler/desugared/ast.mli b/compiler/desugared/ast.mli index 396ffbd4..8c3e43f7 100644 --- a/compiler/desugared/ast.mli +++ b/compiler/desugared/ast.mli @@ -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; } diff --git a/compiler/desugared/dependency.ml b/compiler/desugared/dependency.ml index 597ec3b3..a5840471 100644 --- a/compiler/desugared/dependency.ml +++ b/compiler/desugared/dependency.ml @@ -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 diff --git a/compiler/desugared/from_surface.ml b/compiler/desugared/from_surface.ml index e15cc6f5..17e48499 100644 --- a/compiler/desugared/from_surface.ml +++ b/compiler/desugared/from_surface.ml @@ -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 _ diff --git a/compiler/desugared/linting.ml b/compiler/desugared/linting.ml index 22821349..a8cf4e3b 100644 --- a/compiler/desugared/linting.ml +++ b/compiler/desugared/linting.ml @@ -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) diff --git a/compiler/desugared/name_resolution.ml b/compiler/desugared/name_resolution.ml index 64dbb154..8245550d 100644 --- a/compiler/desugared/name_resolution.ml +++ b/compiler/desugared/name_resolution.ml @@ -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 diff --git a/compiler/desugared/name_resolution.mli b/compiler/desugared/name_resolution.mli index eab8c1a9..e6f4718f 100644 --- a/compiler/desugared/name_resolution.mli +++ b/compiler/desugared/name_resolution.mli @@ -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 *) diff --git a/compiler/lcalc/closure_conversion.ml b/compiler/lcalc/closure_conversion.ml index dd15aab7..72652c88 100644 --- a/compiler/lcalc/closure_conversion.ml +++ b/compiler/lcalc/closure_conversion.ml @@ -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 diff --git a/compiler/lcalc/compile_with_exceptions.ml b/compiler/lcalc/compile_with_exceptions.ml index 8c904bbf..fa36f91e 100644 --- a/compiler/lcalc/compile_with_exceptions.ml +++ b/compiler/lcalc/compile_with_exceptions.ml @@ -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 diff --git a/compiler/lcalc/compile_without_exceptions.ml b/compiler/lcalc/compile_without_exceptions.ml index 0ecbfabd..0bca5672 100644 --- a/compiler/lcalc/compile_without_exceptions.ml +++ b/compiler/lcalc/compile_without_exceptions.ml @@ -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 -> diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index ffa92af1..c4771f64 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -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 "@[(%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@ @[{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@ @[{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 "@[(%a)@]" @@ -274,7 +274,7 @@ let rec format_expr (ctx : decl_ctx) (fmt : Format.formatter) (e : 'm expr) : Format.fprintf fmt "@[%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 diff --git a/compiler/lcalc/to_ocaml.mli b/compiler/lcalc/to_ocaml.mli index 4a5bc73f..3c511b61 100644 --- a/compiler/lcalc/to_ocaml.mli +++ b/compiler/lcalc/to_ocaml.mli @@ -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 diff --git a/compiler/literate/html.ml b/compiler/literate/html.ml index 0c584b26..d1c55af7 100644 --- a/compiler/literate/html.ml +++ b/compiler/literate/html.ml @@ -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 "
%s
" 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 "
\n\ @@ -151,9 +150,9 @@ let rec law_structure_to_html %s\n\
" (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 diff --git a/compiler/literate/latex.ml b/compiler/literate/latex.ml index 81e10436..34803684 100644 --- a/compiler/literate/latex.ml +++ b/compiler/literate/latex.ml @@ -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 diff --git a/compiler/plugins/api_web.ml b/compiler/plugins/api_web.ml index 2f92c82c..a31df1ed 100644 --- a/compiler/plugins/api_web.ml +++ b/compiler/plugins/api_web.ml @@ -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..." diff --git a/compiler/plugins/json_schema.ml b/compiler/plugins/json_schema.ml index 4e2a6e40..2e214237 100644 --- a/compiler/plugins/json_schema.ml +++ b/compiler/plugins/json_schema.ml @@ -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 "@[\"%a\": {@\n\ diff --git a/compiler/plugins/lazy_interp.ml b/compiler/plugins/lazy_interp.ml index 6348707f..93026e62 100644 --- a/compiler/plugins/lazy_interp.ml +++ b/compiler/plugins/lazy_interp.ml @@ -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 diff --git a/compiler/scalc/ast.ml b/compiler/scalc/ast.ml index ca02048f..0c3070e5 100644 --- a/compiler/scalc/ast.ml +++ b/compiler/scalc/ast.ml @@ -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; diff --git a/compiler/scalc/from_lcalc.ml b/compiler/scalc/from_lcalc.ml index 37c91dfd..aeca4146 100644 --- a/compiler/scalc/from_lcalc.ml +++ b/compiler/scalc/from_lcalc.ml @@ -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 diff --git a/compiler/scalc/print.ml b/compiler/scalc/print.ml index 3487d5f1..1c99c4c5 100644 --- a/compiler/scalc/print.ml +++ b/compiler/scalc/print.ml @@ -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 "@[%a@ %a@ %a@ %a@]@\n@[ %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 "@[%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 "@[%a %a@ %a@]" format_var_name - (Marked.unmark name) Print.punctuation "=" + Format.fprintf fmt "@[%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 "@[%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 "@[%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 "@[%a @[%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 " ="; diff --git a/compiler/scalc/to_python.ml b/compiler/scalc/to_python.ml index 27643da9..4e00db54 100644 --- a/compiler/scalc/to_python.ml +++ b/compiler/scalc/to_python.ml @@ -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(@[SourcePosition(@[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 "@[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 "@[%a = %a@]" format_var (Marked.unmark v) + Format.fprintf fmt "@[%a = %a@]" format_var (Mark.remove v) (format_expression ctx) e | STryExcept (try_b, except, catch_b) -> Format.fprintf fmt "@[try:@\n%a@]@\n@[except %a:@\n%a@]" @@ -409,7 +409,7 @@ let rec format_statement (format_block ctx) catch_b | SRaise except -> Format.fprintf fmt "@[raise %a@]" format_exception - (except, Marked.get_mark s) + (except, Mark.get s) | SIfThenElse (cond, b1, b2) -> Format.fprintf fmt "@[if %a:@\n%a@]@\n@[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 "@[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 "@[if not (%a):@\n\ raise AssertionFailure(@[SourcePosition(@[filename=\"%s\",@ start_line=%d,@ start_column=%d,@ end_line=%d,@ \ end_column=%d,@ law_headings=@[%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) diff --git a/compiler/scopelang/ast.ml b/compiler/scopelang/ast.ml index 2f9eebfb..87813dc3 100644 --- a/compiler/scopelang/ast.ml +++ b/compiler/scopelang/ast.ml @@ -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 diff --git a/compiler/scopelang/ast.mli b/compiler/scopelang/ast.mli index 6d280abc..7ae5fb3f 100644 --- a/compiler/scopelang/ast.mli +++ b/compiler/scopelang/ast.mli @@ -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 = { diff --git a/compiler/scopelang/dependency.ml b/compiler/scopelang/dependency.ml index 8083e701..d156c5ac 100644 --- a/compiler/scopelang/dependency.ml +++ b/compiler/scopelang/dependency.ml @@ -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 diff --git a/compiler/scopelang/from_desugared.ml b/compiler/scopelang/from_desugared.ml index b9cd38e6..8fea50a6 100644 --- a/compiler/scopelang/from_desugared.ml +++ b/compiler/scopelang/from_desugared.ml @@ -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 diff --git a/compiler/scopelang/print.ml b/compiler/scopelang/print.ml index 1beaa529..cc80cd3e 100644 --- a/compiler/scopelang/print.ml +++ b/compiler/scopelang/print.ml @@ -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 "@[%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 -> diff --git a/compiler/shared_ast/definitions.ml b/compiler/shared_ast/definitions.ml index dda84ee9..5e11bc93 100644 --- a/compiler/shared_ast/definitions.ml +++ b/compiler/shared_ast/definitions.ml @@ -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 diff --git a/compiler/shared_ast/expr.ml b/compiler/shared_ast/expr.ml index 9c6ce406..1acd254c 100644 --- a/compiler/shared_ast/expr.ml +++ b/compiler/shared_ast/expr.ml @@ -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 diff --git a/compiler/shared_ast/expr.mli b/compiler/shared_ast/expr.mli index f55e4034..5621d40f 100644 --- a/compiler/shared_ast/expr.mli +++ b/compiler/shared_ast/expr.mli @@ -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 diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index 08a2f640..8669f196 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -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) diff --git a/compiler/shared_ast/operator.ml b/compiler/shared_ast/operator.ml index 6ce21682..ae90537a 100644 --- a/compiler/shared_ast/operator.ml +++ b/compiler/shared_ast/operator.ml @@ -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) diff --git a/compiler/shared_ast/operator.mli b/compiler/shared_ast/operator.mli index ce4049e8..a50f79d2 100644 --- a/compiler/shared_ast/operator.mli +++ b/compiler/shared_ast/operator.mli @@ -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. diff --git a/compiler/shared_ast/optimizations.ml b/compiler/shared_ast/optimizations.ml index f14941d9..71143a52 100644 --- a/compiler/shared_ast/optimizations.ml +++ b/compiler/shared_ast/optimizations.ml @@ -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 diff --git a/compiler/shared_ast/print.ml b/compiler/shared_ast/print.ml index ee38d7bd..6ce17762 100644 --- a/compiler/shared_ast/print.ml +++ b/compiler/shared_ast/print.ml @@ -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 "@[(%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 "@[%a%a%a@]" punctuation "(" diff --git a/compiler/shared_ast/scope.ml b/compiler/shared_ast/scope.ml index 8638c33f..1ccf45ee 100644 --- a/compiler/shared_ast/scope.ml +++ b/compiler/shared_ast/scope.ml @@ -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 diff --git a/compiler/shared_ast/type.ml b/compiler/shared_ast/type.ml index f8134202..2c01f7b9 100644 --- a/compiler/shared_ast/type.ml +++ b/compiler/shared_ast/type.ml @@ -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 diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index e3e59514..c9091311 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -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 "@[(%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 diff --git a/compiler/surface/ast.ml b/compiler/surface/ast.ml index f9c2478c..9c22a447 100644 --- a/compiler/surface/ast.ml +++ b/compiler/surface/ast.ml @@ -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 }) diff --git a/compiler/surface/fill_positions.ml b/compiler/surface/fill_positions.ml index 6fa2ec94..376be5e1 100644 --- a/compiler/surface/fill_positions.ml +++ b/compiler/surface/fill_positions.ml @@ -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 diff --git a/compiler/surface/parser.mly b/compiler/surface/parser.mly index 29a7ed2d..104924e6 100644 --- a/compiler/surface/parser.mly +++ b/compiler/surface/parser.mly @@ -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 addpos(UIDENT) +%type addpos(UIDENT) %type pos(CONDITION) %type primitive_typ %type typ_data %type typ -%type uident -%type lident +%type uident +%type lident %type scope_var -%type quident -%type qlident +%type quident +%type qlident %type expression %type naked_expression -%type struct_content_field +%type struct_content_field %type struct_or_enum_inject %type num_literal %type unit_literal %type literal -%type<(Ast.lident Marked.pos * expression) list> scope_call_args +%type<(Ast.lident Mark.pos * expression) list> scope_call_args %type minmax %type unop %type binop %type constructor_binding %type match_arm %type condition_consequence -%type rule_expr +%type rule_expr %type rule_consequence %type rule -%type definition_parameters -%type label -%type state +%type definition_parameters +%type label +%type state %type exception_to %type definition %type variation_type %type assertion -%type scope_item -%type struct_scope_base +%type scope_item +%type struct_scope_base %type struct_scope %type scope_decl_item_attribute_input %type scope_decl_item_attribute_output @@ -91,7 +91,7 @@ end> %type enum_decl_line %type code_item %type code -%type metadata_block +%type metadata_block %type law_heading %type law_text %type 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 = diff --git a/compiler/surface/parser_driver.ml b/compiler/surface/parser_driver.ml index dd1cd47a..a0d4eb5a 100644 --- a/compiler/surface/parser_driver.ml +++ b/compiler/surface/parser_driver.ml @@ -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 = diff --git a/compiler/surface/print.ml b/compiler/surface/print.ml index a439fc45..75dd20fe 100644 --- a/compiler/surface/print.ml +++ b/compiler/surface/print.ml @@ -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) diff --git a/compiler/verification/conditions.ml b/compiler/verification/conditions.ml index 1e3318a0..bcf5091b 100644 --- a/compiler/verification/conditions.ml +++ b/compiler/verification/conditions.ml @@ -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 } -> (* 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 diff --git a/compiler/verification/conditions.mli b/compiler/verification/conditions.mli index 97420c20..d3809544 100644 --- a/compiler/verification/conditions.mli +++ b/compiler/verification/conditions.mli @@ -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 : diff --git a/compiler/verification/io.ml b/compiler/verification/io.ml index aaf0914d..eb89ff94 100644 --- a/compiler/verification/io.ml +++ b/compiler/verification/io.ml @@ -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 diff --git a/compiler/verification/z3backend.real.ml b/compiler/verification/z3backend.real.ml index 10bf1f68..b6b18a43 100644 --- a/compiler/verification/z3backend.real.ml +++ b/compiler/verification/z3backend.real.ml @@ -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 diff --git a/french_law/catala_legifrance/catala_legifrance.ml b/french_law/catala_legifrance/catala_legifrance.ml index eaca84c7..a897cc8a 100644 --- a/french_law/catala_legifrance/catala_legifrance.ml +++ b/french_law/catala_legifrance/catala_legifrance.ml @@ -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 -> ""