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/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, 'm) ed = 'a * 'm
-type 'a pos = ('a, Pos.t) t
+type 'a pos = ('a, Pos.t) ed
 
-let mark m e : ('a, 'm) t = e, m
+let add m e = e, m
-let unmark ((x, _) : ('a, 'm) t) : 'a = x
+let remove (x, _) = x
-let get_mark ((_, x) : ('a, 'm) t) : 'm = x
+let get (_, x) = x
-let map_mark (f : 'm1 -> 'm2) ((a, m) : ('a, 'm1) t) : ('a, 'm2) t = a, f m
+let map f (x, m) = f x, m
-let map_under_mark (f : 'a -> 'b) ((x, y) : ('a, 'm) t) : ('b, 'c) t = f x, y
+let map_mark f (a, m) = a, f m
-let same_mark_as (x : 'a) ((_, y) : ('b, 'm) t) : ('a, 'm) t = x, y
+let copy (_, m) x = x, m
-
+let fold f (x, _) = f x
-let unmark_option (x : ('a, 'm) t option) : 'a option =
+let fold2 f (x, _) (y, _) = f x y
-  match x with Some x -> Some (unmark x) | None -> None
+let compare cmp a b = fold2 cmp a b
-
+let equal eq a b = fold2 eq a b
-let compare (cmp : 'a -> 'a -> int) ((x, _) : ('a, 'm) t) ((y, _) : ('a, 'm) t)
-    : int =
-  cmp x y
 
 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 =
+        : 'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) ed -> ('a, 'm) ed =
-      fun f env x -> same_mark_as (f env (unmark x)) x
+      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
+    method visit_marked
-        =
+        : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) ed -> unit =
-      fun f env x -> f env (unmark x)
+      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 =
+        : 'a. ('env -> 'a -> 'a) -> 'env -> ('a, 'm) ed -> ('a, 'm) ed =
-      fun f env x -> same_mark_as (f env (unmark x)) x
+      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 =
+    method visit_pos : 'a. ('env -> 'a -> unit) -> 'env -> ('a, 'm) ed -> unit =
-      fun f env x -> f env (unmark x)
+      fun f env (x, _) -> f env x
   end

compiler/catala_utils/mark.mli

@@ -17,23 +17,28 @@
 
 (** AST node annotations (used for position, type, etc.) *)
 
-type ('a, 'm) t = 'a * 'm
+type ('a, 'm) ed = 'a * 'm
-(** Everything related to the source code should keep at least its position
+(** The type of [Mark.ed] values. Everything related to the source code should
-    stored, to improve error messages *)
+    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 add : 'm -> 'a -> ('a, 'm) ed
-val unmark : ('a, 'm) t -> 'a
+val remove : ('a, 'm) ed -> 'a
-val get_mark : ('a, 'm) t -> 'm
+val get : ('a, 'm) ed -> 'm
-val map_mark : ('m1 -> 'm2) -> ('a, 'm1) t -> ('a, 'm2) t
+val map : ('a -> 'b) -> ('a, 'm) ed -> ('b, 'm) ed
-val map_under_mark : ('a -> 'b) -> ('a, 'm) t -> ('b, 'm) t
+val map_mark : ('m1 -> 'm2) -> ('a, 'm1) ed -> ('a, 'm2) ed
-val same_mark_as : 'a -> ('b, 'm) t -> ('a, 'm) t
+val copy : ('b, 'm) ed -> 'a -> ('a, 'm) ed
-val unmark_option : ('a, 'm) t option -> 'a option
+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
+val compare : ('a -> 'a -> int) -> ('a, 'm) ed -> ('a, 'm) ed -> int
-(** Compares two marked values {b ignoring positions} *)
+(** 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

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 equal = Mark.equal String.equal
-  let compare i1 i2 = String.compare (Marked.unmark i1) (Marked.unmark i2)
+  let compare = Mark.compare String.compare
 end
 
 module Gen () = Make (MarkedString) ()

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. *)

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
+  let pos = Mark.get io_in in
-  match Marked.unmark io_in with
+  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
+  let m = Mark.get e in
-  match Marked.unmark e with
+  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
+                  Mark.get (StructField.get_info var_ctx.scope_input_name) );
-                    (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";
+          Mark.add (Expr.pos e) "direct";
-          Marked.mark (Expr.pos e) "input";
+          Mark.add (Expr.pos e) "input";
         ]
     in
     let direct_output_info =
       [
         ScopeName.get_info scope;
-        Marked.mark (Expr.pos e) "direct";
+        Mark.add (Expr.pos e) "direct";
-        Marked.mark (Expr.pos e) "output";
+        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))
+                       (VarDef (Mark.remove t_out))
-                       (f_markings @ [Marked.mark (Expr.pos e) "output"]))
+                       (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,
+          List.map Mark.remove marked_input_typ, Mark.remove marked_output_typ
-            Marked.unmark 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 =
+        let _, typ = TopdefName.Map.find (Mark.remove tvar) ctx.toplevel_vars in
-          TopdefName.Map.find (Marked.unmark 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)
+        ScopeVar.Map.find (Mark.remove a)
-          (SubScopeName.Map.find (Marked.unmark s) ctx.subscope_vars)
+          (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
+        SubScopeName.format_t (Mark.remove s) ScopeVar.format_t (Mark.remove a)
-        (Marked.unmark a) SubScopeName.format_t (Marked.unmark s))
+        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_name = ScopeVar.get_info (Mark.remove a) in
-    let a_var = Var.make (Marked.unmark a_name) 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 =
+    let is_func = match Mark.remove tau with TArrow _ -> true | _ -> false in
-      match Marked.unmark 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)
+          ScopeVar.Map.add (Mark.remove a)
-            (a_var, Marked.unmark tau, a_io)
+            (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)))
+          str ^ "." ^ Mark.remove (ScopeVar.get_info (Mark.remove subs_var)))
-        (SubScopeName.get_info (Marked.unmark subs_index))
+        (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 =
+    let is_func = match Mark.remove tau with TArrow _ -> true | _ -> false in
-      match Marked.unmark 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)
+                  (ScopeVar.Map.add (Mark.remove subs_var)
-                     (a_var, Marked.unmark tau, a_io)
+                     (a_var, Mark.remove tau, a_io)
                      map)
               | None ->
                 Some
-                  (ScopeVar.Map.singleton (Marked.unmark subs_var)
+                  (ScopeVar.Map.singleton (Mark.remove subs_var)
-                     (a_var, Marked.unmark tau, a_io)))
+                     (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
+                  Mark.add
-                    (Expr.map_ty (fun _ -> scope_let_typ) (Marked.get_mark e))
+                    (Expr.map_ty (fun _ -> scope_let_typ) (Mark.get e))
-                    (EAssert (Marked.same_mark_as (EErrorOnEmpty new_e) 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
+            (Mark.map (fun s -> s ^ "_in") (ScopeName.get_info scope_name))
-               (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 =
+                    scope_input_name = StructField.fresh (s, Mark.get info);
-                      StructField.fresh (s, Marked.get_mark 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
     {

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

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 (x, None) -> Mark.get (ScopeVar.get_info x)
-      | Var (_, Some sx) -> Marked.get_mark (StateName.get_info sx)
+      | 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 =
+module LocationSet : Set.S with type elt = location Mark.pos = Set.Make (struct
-Set.Make (struct
+  type t = location Mark.pos
-  type t = location Marked.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
+  | ExceptionToLabel of LabelName.t Mark.pos
-  | ExceptionToRule of RuleName.t Marked.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
+        (Mark.map (List.map (fun (lbl, typ) -> Mark.map Var.make lbl, typ)))
-           (List.map (fun (lbl, typ) -> Marked.map_under_mark 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
+        (Mark.map (List.map (fun (lbl, typ) -> Mark.map Var.make lbl, typ)))
-           (List.map (fun (lbl, typ) -> Marked.map_under_mark 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
+  | FixedBy of reference_typ Mark.pos
-  | VariesWith of unit * variation_typ Marked.pos option
+  | 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) ->
+          | DesugaredScopeVar (v, st) -> Some (ScopeDef.Var (Mark.remove v, st))
-            Some (ScopeDef.Var (Marked.unmark v, st))
           | SubScopeVar (_, sub_index, sub_var) ->
             Some
               (ScopeDef.SubScopeVar
-                 ( Marked.unmark sub_index,
+                 (Mark.remove sub_index, Mark.remove sub_var, Mark.get sub_index))
-                   Marked.unmark sub_var,
-                   Marked.get_mark sub_index ))
           | ToplevelVar _ -> None
         in
         match usage with

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
+  | ExceptionToLabel of LabelName.t Mark.pos
-  | ExceptionToRule of RuleName.t Marked.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
+  | FixedBy of reference_typ Mark.pos
-  | VariesWith of unit * variation_typ Marked.pos option
+  | 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;
 }
 

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
+              match Mark.remove used_var with
-              | DesugaredScopeVar (v, s) ->
+              | DesugaredScopeVar (v, s) -> Some (Vertex.Var (Mark.remove v, s))
-                Some (Vertex.Var (Marked.unmark 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

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
+      Errors.raise_spanned_error (Mark.get constructor)
-        (Marked.get_mark 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
+      Errors.raise_spanned_error (Mark.get constructor)
-        (Marked.get_mark 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)
+          (Mark.remove enum) (Mark.remove constructor)
-          (Marked.unmark constructor)
     with Not_found ->
-      Errors.raise_spanned_error (Marked.get_mark enum)
+      Errors.raise_spanned_error (Mark.get enum)
-        "Enum %s has not been defined before" (Marked.unmark 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)
+            Errors.raise_spanned_error (Mark.get c)
-              "Structure %s was not declared" (Marked.unmark 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 ctxt, v = Name_resolution.add_def_local_var ctxt (Mark.remove x) in
-    let tau = TAny, Marked.get_mark 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)
+        Errors.raise_spanned_error (Mark.get enum)
-          "Enum %s has not been defined before" (Marked.unmark 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))
+        (fst (Mark.remove pattern))
-        (Marked.get_mark 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 =
+      let acc = Expr.make_var acc_var (Untyped { pos = Mark.get param0 }) in
-        Expr.make_var acc_var (Untyped { pos = Marked.get_mark 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)
+    Expr.eapp op_term [precond; cond] (Mark.get cond)
-  | Some precond, None -> Marked.unmark precond, Untyped { pos = default_pos }
+  | 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
+    process_rule_parameters ctxt (Mark.copy def.definition_name def_key) def
-      (Marked.same_mark_as def_key def.definition_name)
-      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
+          Errors.raise_spanned_error (Mark.get label_str)
-            (Marked.get_mark 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))
+              Mark.copy cond (Surface.Ast.Literal (Surface.Ast.LBool true)) ),
-                cond ),
+          Mark.get cond ))
-          Marked.get_mark cond ))
   in
   let assertion =
     match precond with
     | Some precond ->
       Expr.eifthenelse precond ass
-        (Expr.elit (LBool true) (Marked.get_mark precond))
+        (Expr.elit (LBool true) (Mark.get precond))
-        (Marked.get_mark 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)
+            (Mark.remove rule.rule_name)
-            rule.rule_state scope ctxt
+            rule.rule_state scope ctxt (Mark.get rule.rule_name),
-            (Marked.get_mark 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
+                       else Ast.NoInput, Mark.get (StateName.get_info state)
-                         Ast.NoInput, Marked.get_mark (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
+              Ast.ScopeDef.SubScopeVar (v0, v, Mark.get (ScopeVar.get_info v))
-                (v0, v, Marked.get_mark (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 _

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)

compiler/desugared/name_resolution.ml

@@ -23,9 +23,7 @@ open Shared_ast
 
 (** {1 Name resolution context} *)
 
-type unique_rulename =
+type unique_rulename = Ambiguous of Pos.t list | Unique of RuleName.t Mark.pos
-  | Ambiguous of Pos.t list
-  | Unique of RuleName.t Marked.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) =
+let raise_unknown_identifier (msg : string) (ident : IdentName.t Mark.pos) =
-  Errors.raise_spanned_error (Marked.get_mark ident)
+  Errors.raise_spanned_error (Mark.get ident) "\"%s\": unknown identifier %s"
-    "\"%s\": unknown identifier %s"
+    (Cli.with_style [ANSITerminal.yellow] "%s" (Mark.remove ident))
-    (Cli.with_style [ANSITerminal.yellow] "%s" (Marked.unmark 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;
+        None, Mark.get id;
-        Some "Structure defined at", Marked.get_mark (StructName.get_info sid);
+        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;
+        None, Mark.get id;
-        Some "Scope defined at", Marked.get_mark (ScopeName.get_info sid);
+        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"
+    Errors.raise_spanned_error (Mark.get id) "No enum named %s found"
-      (Marked.unmark id)
+      (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;
+        None, Mark.get id;
-        Some "Enum defined at", Marked.get_mark (EnumName.get_info eid);
+        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"
+    Errors.raise_spanned_error (Mark.get id) "No struct named %s found"
-      (Marked.unmark id)
+      (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;
+        None, Mark.get id;
-        Some "Enum defined at", Marked.get_mark (EnumName.get_info eid);
+        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;
+        None, Mark.get id;
-        Some "Structure defined at", Marked.get_mark (StructName.get_info sid);
+        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"
+    Errors.raise_spanned_error (Mark.get id) "No scope named %s found"
-      (Marked.unmark id)
+      (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
+        (process_base_typ ctxt (Surface.Ast.Data (Mark.remove t), Mark.get t)),
-           (Surface.Ast.Data (Marked.unmark t), Marked.get_mark 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
+        (Mark.map (List.map (fun (lbl, typ) -> lbl, process_type ctxt typ)))
-           (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)
+let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
-    : context =
+    context =
   let raise_already_defined_error (use : Uid.MarkedString.info) name pos msg =
     Errors.raise_multispanned_error
-      [
+      [Some "First definition:", Mark.get use; Some "Second definition:", pos]
-        Some "First definition:", Marked.get_mark 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)
+let process_decl_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
-    : context =
+    context =
-  match Marked.unmark item with
+  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;
+                None, Mark.get state;
-                ( Some "Variable declaration:",
+                Some "Variable declaration:", Mark.get (ScopeVar.get_info x_uid);
-                  Marked.get_mark (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;
+                None, Mark.get x;
-                ( Some "Variable declaration:",
+                Some "Variable declaration:", Mark.get (ScopeVar.get_info x_uid);
-                  Marked.get_mark (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 =
+    (sitem : Surface.Ast.scope_use_item Mark.pos) : context =
-  match Marked.unmark sitem with
+  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)
+let process_use_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
-    : context =
+    context =
-  match Marked.unmark item with
+  match Mark.remove item with
   | ScopeDecl _ | StructDecl _ | EnumDecl _ | Topdef _ -> ctxt
   | ScopeUse suse -> process_scope_use ctxt suse
 

compiler/desugared/name_resolution.mli

@@ -23,9 +23,7 @@ open Shared_ast
 
 (** {1 Name resolution context} *)
 
-type unique_rulename =
+type unique_rulename = Ambiguous of Pos.t list | Unique of RuleName.t Mark.pos
-  | Ambiguous of Pos.t list
-  | Unique of RuleName.t Marked.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 *)
 

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 =
+let tys_as_tanys tys = List.map (fun x -> Mark.map (fun _ -> TAny) x) tys
-  List.map (fun x -> Marked.map_under_mark (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
+  let m = Mark.get e in
-  match Marked.unmark e with
+  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
+  let m = Mark.get e in
-  match Marked.unmark e with
+  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
+                (StructField.Map.map (fun t -> Mark.copy t TAny) (Option.get s))
-                   (fun t -> Marked.same_mark_as TAny t)
-                   (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

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
+  let m = Mark.get e in
-  match Marked.unmark e with
+  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))
+         (Expr.eraise EmptyError (Mark.get e))
-         (Marked.get_mark e))
+         (Mark.get e))
-      (Marked.get_mark 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

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
+  let m = Mark.get tau in
-  (Fun.flip Marked.same_mark_as)
+  Mark.copy tau
-    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 ->

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

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

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

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_end_line (Mark.get c)
-    - Pos.get_start_line (Marked.get_mark 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 start_line = Pos.get_start_line (Mark.get c) - 1 in
-    let filename = Pos.get_file (Marked.get_mark c) in
+    let filename = Pos.get_file (Mark.get c) in
-    let block_content = Marked.unmark 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 start_line = Pos.get_start_line (Mark.get c) + 1 in
-    let filename = Pos.get_file (Marked.get_mark c) in
+    let filename = Pos.get_file (Mark.get c) in
-    let block_content = Marked.unmark 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

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..."

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
                "@[<hov 2>\"%a\": {@\n\

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

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
+  | SInnerFuncDef of VarName.t Mark.pos * func
-  | SLocalDecl of VarName.t Marked.pos * typ
+  | SLocalDecl of VarName.t Mark.pos * typ
-  | SLocalDef of VarName.t Marked.pos * expr
+  | 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 block = stmt Mark.pos list
-
+and func = { func_params : (VarName.t Mark.pos * typ) list; func_body : block }
-and func = {
-  func_params : (VarName.t Marked.pos * typ) list;
-  func_body : block;
-}
 
 type scope_body = {
   scope_body_name : ScopeName.t;

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);
+              inside_definition_of = Some (Mark.remove x);
-              context_name =
+              context_name = Mark.remove (A.VarName.get_info (Mark.remove x));
-                Marked.unmark (A.VarName.get_info (Marked.unmark 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)
+          | None -> A.SReturn (Mark.remove new_e)
-          | Some x -> A.SLocalDef (Marked.same_mark_as x new_e, 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
+                           block @ [A.SReturn (Mark.remove expr), Mark.get expr];
-                           @ [
-                               ( A.SReturn (Marked.unmark expr),
-                                 Marked.get_mark expr );
-                             ];
                        };
                    }
               :: rev_items

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 "@[<hov 2>%a@ %a@ %a@ %a@]@\n@[<v 2>  %a@]" Print.keyword
-      "let" format_var_name (Marked.unmark name)
+      "let" format_var_name (Mark.remove name)
       (Format.pp_print_list
          ~pp_sep:(fun fmt () -> Format.fprintf fmt "@ ")
          (fun fmt ((name, _), typ) ->
@@ -108,11 +108,11 @@ let rec format_statement
       func.func_body
   | SLocalDecl (name, typ) ->
     Format.fprintf fmt "@[<hov 2>%a %a %a@ %a@]" Print.keyword "decl"
-      format_var_name (Marked.unmark name) Print.punctuation ":"
+      format_var_name (Mark.remove name) Print.punctuation ":"
       (Print.typ decl_ctx) typ
   | SLocalDef (name, naked_expr) ->
-    Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" format_var_name
+    Format.fprintf fmt "@[<hov 2>%a %a@ %a@]" format_var_name (Mark.remove name)
-      (Marked.unmark name) Print.punctuation "="
+      Print.punctuation "="
       (format_expr decl_ctx ~debug)
       naked_expr
   | STryExcept (b_try, except, b_with) ->
@@ -137,11 +137,11 @@ let rec format_statement
   | SReturn ret ->
     Format.fprintf fmt "@[<hov 2>%a %a@]" Print.keyword "return"
       (format_expr decl_ctx ~debug)
-      (ret, Marked.get_mark stmt)
+      (ret, Mark.get stmt)
   | SAssert naked_expr ->
     Format.fprintf fmt "@[<hov 2>%a %a@]" Print.keyword "assert"
       (format_expr decl_ctx ~debug)
-      (naked_expr, Marked.get_mark stmt)
+      (naked_expr, Mark.get stmt)
   | SSwitch (e_switch, enum, arms) ->
     Format.fprintf fmt "@[<v 0>%a @[<hov 2>%a@]%a@]%a" Print.keyword "switch"
       (format_expr decl_ctx ~debug)
@@ -186,7 +186,7 @@ let format_item decl_ctx ?debug ppf def =
       format_func_name ppf var;
       Format.pp_print_list
         (fun ppf (arg, ty) ->
-          Format.fprintf ppf "@ (%a: %a)" format_var_name (Marked.unmark arg)
+          Format.fprintf ppf "@ (%a: %a)" format_var_name (Mark.remove arg)
             (Print.typ decl_ctx) ty)
         ppf func.func_params;
       Print.punctuation ppf " =";

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 =
+let format_lit (fmt : Format.formatter) (l : lit Mark.pos) : unit =
-  match Marked.unmark l with
+  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 =
+let format_op (fmt : Format.formatter) (op : operator Mark.pos) : unit =
-  match Marked.unmark op with
+  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 format_exception (fmt : Format.formatter) (exc : except Mark.pos) : unit =
-  let pos = Marked.get_mark exc in
+  let pos = Mark.get exc in
-  match Marked.unmark exc with
+  match Mark.remove exc with
   | ConflictError ->
     Format.fprintf fmt
       "ConflictError(@[<hov 0>SourcePosition(@[<hov 0>filename=\"%s\",@ \
@@ -279,7 +279,7 @@ let format_exception (fmt : Format.formatter) (exc : except Marked.pos) : unit =
 
 let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
     unit =
-  match Marked.unmark e with
+  match Mark.remove e with
   | EVar v -> format_var fmt v
   | EFunc f -> format_func_name fmt f
   | EStruct (es, s) ->
@@ -314,7 +314,7 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
          ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
          (fun fmt e -> Format.fprintf fmt "%a" (format_expression ctx) e))
       es
-  | ELit l -> Format.fprintf fmt "%a" format_lit (Marked.same_mark_as l e)
+  | ELit l -> Format.fprintf fmt "%a" format_lit (Mark.copy e l)
   | EApp ((EOp ((Map | Filter) as op), _), [arg1; arg2]) ->
     Format.fprintf fmt "%a(%a,@ %a)" format_op (op, Pos.no_pos)
       (format_expression ctx) arg1 (format_expression ctx) arg2
@@ -387,21 +387,21 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) :
 let rec format_statement
     (ctx : decl_ctx)
     (fmt : Format.formatter)
-    (s : stmt Marked.pos) : unit =
+    (s : stmt Mark.pos) : unit =
-  match Marked.unmark s with
+  match Mark.remove s with
   | SInnerFuncDef (name, { func_params; func_body }) ->
     Format.fprintf fmt "@[<hov 4>def %a(%a):@\n%a@]" format_var
-      (Marked.unmark name)
+      (Mark.remove name)
       (Format.pp_print_list
          ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
          (fun fmt (var, typ) ->
-           Format.fprintf fmt "%a:%a" format_var (Marked.unmark var) format_typ
+           Format.fprintf fmt "%a:%a" format_var (Mark.remove var) format_typ
              typ))
       func_params (format_block ctx) func_body
   | SLocalDecl _ ->
     assert false (* We don't need to declare variables in Python *)
   | SLocalDef (v, e) ->
-    Format.fprintf fmt "@[<hov 4>%a = %a@]" format_var (Marked.unmark v)
+    Format.fprintf fmt "@[<hov 4>%a = %a@]" format_var (Mark.remove v)
       (format_expression ctx) e
   | STryExcept (try_b, except, catch_b) ->
     Format.fprintf fmt "@[<hov 4>try:@\n%a@]@\n@[<hov 4>except %a:@\n%a@]"
@@ -409,7 +409,7 @@ let rec format_statement
       (format_block ctx) catch_b
   | SRaise except ->
     Format.fprintf fmt "@[<hov 4>raise %a@]" format_exception
-      (except, Marked.get_mark s)
+      (except, Mark.get s)
   | SIfThenElse (cond, b1, b2) ->
     Format.fprintf fmt "@[<hov 4>if %a:@\n%a@]@\n@[<hov 4>else:@\n%a@]"
       (format_expression ctx) cond (format_block ctx) b1 (format_block ctx) b2
@@ -447,16 +447,16 @@ let rec format_statement
       cases
   | SReturn e1 ->
     Format.fprintf fmt "@[<hov 4>return %a@]" (format_expression ctx)
-      (e1, Marked.get_mark s)
+      (e1, Mark.get s)
   | SAssert e1 ->
-    let pos = Marked.get_mark s in
+    let pos = Mark.get s in
     Format.fprintf fmt
       "@[<hov 4>if not (%a):@\n\
        raise AssertionFailure(@[<hov 0>SourcePosition(@[<hov \
        0>filename=\"%s\",@ start_line=%d,@ start_column=%d,@ end_line=%d,@ \
        end_column=%d,@ law_headings=@[<hv>%a@])@])@]@]"
       (format_expression ctx)
-      (e1, Marked.get_mark s)
+      (e1, Mark.get s)
       (Pos.get_file pos) (Pos.get_start_line pos) (Pos.get_start_column pos)
       (Pos.get_end_line pos) (Pos.get_end_column pos) format_string_list
       (Pos.get_law_info pos)
@@ -466,7 +466,7 @@ and format_block (ctx : decl_ctx) (fmt : Format.formatter) (b : block) : unit =
     ~pp_sep:(fun fmt () -> Format.fprintf fmt "@\n")
     (format_statement ctx) fmt
     (List.filter
-       (fun s -> match Marked.unmark s with SLocalDecl _ -> false | _ -> true)
+       (fun s -> match Mark.remove s with SLocalDecl _ -> false | _ -> true)
        b)
 
 let format_ctx
@@ -625,7 +625,7 @@ let format_program
                (Format.pp_print_list
                   ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ")
                   (fun fmt (var, typ) ->
-                    Format.fprintf fmt "%a:%a" format_var (Marked.unmark var)
+                    Format.fprintf fmt "%a:%a" format_var (Mark.remove var)
                       format_typ typ))
                func_params (format_block p.decl_ctx) func_body))
         p.code_items)

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 =
+module LocationSet : Set.S with type elt = location Mark.pos = Set.Make (struct
-Set.Make (struct
+  type t = location Mark.pos
-  type t = location Marked.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 =
+          let pos = Mark.get (ScopeName.get_info scope_decl.scope_decl_name) in
-            Marked.get_mark (ScopeName.get_info scope_decl.scope_decl_name)
+          Typed { pos; ty = Mark.add pos TAny }
-          in
-          Typed { pos; ty = Marked.mark pos TAny }
         in
         { scope_decl with scope_decl_rules; scope_mark })
       prg.program_scopes

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 = {

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)
+    VMap.singleton (Scope subscope) (Mark.get (SubScopeName.get_info subindex))
-      (Marked.get_mark (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 =
+                  let edge = TDependencies.E.create used (Mark.get typ) def in
-                    TDependencies.E.create used (Marked.get_mark 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 =
+                  let edge = TDependencies.E.create used (Mark.get typ) def in
-                    TDependencies.E.create used (Marked.get_mark 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:"),
+              Some ("Cycle type " ^ var_str ^ ", declared:"), Mark.get var_info;
-                Marked.get_mark var_info );
               ( Some
                   ("Used here in the definition of another cycle type "
                   ^ succ_str

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))
+      (Expr.eop (Log (l, markings)) [TAny, Expr.pos e] (Mark.get e))
-      [e] (Marked.get_mark 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
+  let m = Mark.get e in
-  match Marked.unmark e with
+  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
+      match ScopeVar.Map.find (Mark.remove s_var) ctx.scope_var_mapping with
-      | WholeVar new_s_var -> Marked.same_mark_as new_s_var s_var
+      | WholeVar new_s_var -> Mark.copy s_var new_s_var
-      | States states ->
+      | States states -> Mark.copy s_var (snd (List.hd (List.rev states)))
-        Marked.same_mark_as (snd (List.hd (List.rev states))) s_var
     in
     Expr.elocation (SubScopeVar (s_name, ss_name, new_s_var)) m
   | ELocation (DesugaredScopeVar (s_var, None)) ->
     Expr.elocation
       (ScopelangScopeVar
-         (match
+         (match ScopeVar.Map.find (Mark.remove s_var) ctx.scope_var_mapping with
-            ScopeVar.Map.find (Marked.unmark s_var) ctx.scope_var_mapping
+         | WholeVar new_s_var -> Mark.copy s_var new_s_var
-          with
-         | WholeVar new_s_var -> Marked.same_mark_as new_s_var s_var
          | States _ -> failwith "should not happen"))
       m
   | ELocation (DesugaredScopeVar (s_var, Some state)) ->
     Expr.elocation
       (ScopelangScopeVar
-         (match
+         (match ScopeVar.Map.find (Mark.remove s_var) ctx.scope_var_mapping with
-            ScopeVar.Map.find (Marked.unmark 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
+          Operator.resolve_overload ctx.decl_ctx (Mark.add (Expr.pos e) op) tys
-            (Marked.mark (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
+      let binder = Bindlib.bind_mvar old_params (Mark.remove e) in
-      Marked.mark (Marked.get_mark e)
+      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)),
+                (scope_var, Mark.get (ScopeVar.get_info scope_var)),
-              Marked.get_mark (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
+            Untyped { pos = Mark.get (SubScopeName.get_info sub_scope_index) }
-              { pos = Marked.get_mark (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)
+                    (Mark.map (( ^ ) var_prefix) (StateName.get_info state))
-                       (StateName.get_info state))
                 in
                 States (List.map (fun state -> state, state_var state) states)
             in

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 "@[<hov 2>%a %a %a %a %a@ %a@]" Print.keyword
-             "let" Print.location (Marked.unmark loc) Print.punctuation ":"
+             "let" Print.location (Mark.remove loc) Print.punctuation ":"
              (Print.typ ctx) typ Print.punctuation "="
              (fun fmt e ->
-               match Marked.unmark loc with
+               match Mark.remove loc with
                | SubScopeVar _ | ToplevelVar _ -> Print.expr () fmt e
                | ScopelangScopeVar v -> (
                  match
-                   Marked.unmark
+                   Mark.remove
-                     (snd (ScopeVar.Map.find (Marked.unmark v) decl.scope_sig))
+                     (snd (ScopeVar.Map.find (Mark.remove v) decl.scope_sig))
                        .io_input
                  with
                  | Reentrant ->

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

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 ->
+   fun em -> B.box_apply (fun e -> Mark.add (Mark.get em) e) (Mark.remove em)
-    B.box_apply (fun e -> Marked.mark (Marked.get_mark em) e) (Marked.unmark 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 =
+let pos (type m) (x : ('a, m mark) Mark.ed) : Pos.t = mark_pos (Mark.get x)
-  mark_pos (Marked.get_mark 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) :
+let set_ty (type m) (ty : typ) (x : ('a, m mark) Mark.ed) :
-    ('a, typed mark) Marked.t =
+    ('a, typed mark) Mark.ed =
-  Marked.mark
+  Mark.add
-    (match Marked.get_mark x with
+    (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 =
+    (e : ((a, b, 'm1) base_gexpr, 'm2) Mark.ed) : (b, 'm2) boxed_gexpr =
-  let m = Marked.get_mark e in
+  let m = Mark.get e in
-  match Marked.unmark e with
+  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 =
+    (e : ((a, 'm1) naked_gexpr, 'm2) Mark.ed) : 'acc * (a, 'm2) boxed_gexpr =
-  let m = Marked.get_mark e in
+  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)
+    (x : a glocation Mark.pos)
-    (y : a glocation Marked.pos) =
+    (y : a glocation Mark.pos) =
-  match Marked.unmark x, Marked.unmark y with
+  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)))
+      (fun ety -> Mark.add pos (TArrow (taus, ety)))
-      (Marked.get_mark e)
+      (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

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 pos : ('a, 'm mark) Mark.ed -> Pos.t
-val ty : ('e, typed mark) Marked.t -> typ
+val ty : ('e, typed mark) Mark.ed -> typ
-val set_ty : typ -> ('a, 'm mark) Marked.t -> ('a, typed mark) Marked.t
+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 equal_location : 'a glocation Mark.pos -> 'a glocation Mark.pos -> bool
-val compare_location : 'a glocation Marked.pos -> 'a glocation Marked.pos -> int
+val compare_location : 'a glocation Mark.pos -> 'a glocation Mark.pos -> int
 val equal_except : except -> except -> bool
 val compare_except : except -> except -> int
 

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' ->
+         (fun e' -> evaluate_expr (Mark.copy e' (EApp { f; args = [e'] })))
-           evaluate_expr (Marked.same_mark_as (EApp { f; args = [e'] }) 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
+           match evaluate_expr (Mark.copy e' (EApp { f; args = [e'] })) with
-             evaluate_expr (Marked.same_mark_as (EApp { f; args = [e'] }) 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
+        match Mark.remove e with
-        | ELit (LBool true) -> Marked.mark m (ELit LUnit)
+        | 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
+      match Mark.remove just with
-      | EEmptyError -> Marked.mark m EEmptyError
+      | 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)

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)

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 monomorphic_type : monomorphic t Mark.pos -> typ
-val resolved_type : resolved t Marked.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.

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 -> Mark.remove handler
-      | _, ERaise exn' when exn' = exn -> Marked.unmark body
+      | _, ERaise exn' when exn' = exn -> Mark.remove body
       | _ -> ECatch { body; exn; handler })
     | e -> e
   in

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

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
+                (if reset_types then Mark.copy scope_let.scope_let_typ TAny
-                 Marked.same_mark_as TAny scope_let.scope_let_typ
                 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
+    let m = Mark.get e in
-    Expr.with_ty m (Marked.mark (Expr.mark_pos m) TAny)
+    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 input_typ = Mark.add pos (TStruct scope_input_struct_name) in
-  let result_typ = Marked.mark pos (TStruct scope_return_struct_name) in
+  let result_typ = Mark.add pos (TStruct scope_return_struct_name) in
-  Marked.mark pos (TArrow ([input_typ], result_typ))
+  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

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

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 "@[<hov 2>(%a)@]"
@@ -121,7 +121,7 @@ let rec format_typ
          format_typ_with_parens)
       t1 format_typ t2
   | TArray t1 -> (
-    match Marked.unmark (UnionFind.get (UnionFind.find t1)) with
+    match Mark.remove (UnionFind.get (UnionFind.find t1)) with
     | TAny _ when not !Cli.debug_flag -> Format.pp_print_string fmt "collection"
     | _ -> Format.fprintf fmt "@[collection@ %a@]" format_typ t1)
   | TAny v ->
@@ -146,7 +146,7 @@ let rec unify
   let t2_repr = UnionFind.get (UnionFind.find t2) in
   let raise_type_error () = raise (Type_error (A.AnyExpr e, t1, t2)) in
   let () =
-    match Marked.unmark t1_repr, Marked.unmark t2_repr with
+    match Mark.remove t1_repr, Mark.remove t2_repr with
     | TLit tl1, TLit tl2 -> if tl1 <> tl2 then raise_type_error ()
     | TArrow (t11, t12), TArrow (t21, t22) -> (
       unify e t12 t22;
@@ -169,7 +169,7 @@ let rec unify
   in
   ignore
   @@ UnionFind.merge
-       (fun t1 t2 -> match Marked.unmark t2 with TAny _ -> t1 | _ -> t2)
+       (fun t1 t2 -> match Mark.remove t2 with TAny _ -> t1 | _ -> t2)
        t1 t2
 
 let handle_type_error ctx e t1 t2 =
@@ -178,12 +178,12 @@ let handle_type_error ctx e t1 t2 =
   let pos =
     match e with
     | A.AnyExpr e -> (
-      match Marked.get_mark e with Untyped { pos } | Typed { pos; _ } -> pos)
+      match Mark.get e with A.Untyped { pos } -> pos | Typed { pos; _ } -> pos)
   in
   let t1_repr = UnionFind.get (UnionFind.find t1) in
   let t2_repr = UnionFind.get (UnionFind.find t2) in
-  let t1_pos = Marked.get_mark t1_repr in
+  let t1_pos = Mark.get t1_repr in
-  let t2_pos = Marked.get_mark t2_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)
+        Env.get_subscope_out_var env scope (Mark.remove v)
-      | ToplevelVar v -> Env.get_toplevel_var env (Marked.unmark 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,
+          tys, mark_with_tau_and_unify (polymorphic_op_type (Mark.add pos_e op)))
-            mark_with_tau_and_unify (polymorphic_op_type (Marked.mark 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 =
+  let get_pos struct_name = Mark.get (A.StructName.get_info struct_name) in
-    Marked.get_mark (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

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;
+  arg_typ : (lident Mark.pos * base_typ Mark.pos) list;
-  return_typ : base_typ Marked.pos;
+  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_name : uident Mark.pos;
-  struct_decl_fields : struct_decl_field Marked.pos list;
+  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_name : uident Mark.pos;
-  enum_decl_cases : enum_decl_case Marked.pos list;
+  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 =
+        ancestors = ["path_iter"; "lident_iter"; "uident_iter"; "Mark.pos_iter"];
-          ["path_iter"; "lident_iter"; "uident_iter"; "Marked.pos_iter"];
         name = "match_case_pattern_iter";
       }]
 
@@ -336,15 +335,11 @@ type literal_date = {
 }
 [@@deriving
   visitors
-    {
+    { variety = "map"; ancestors = ["Mark.pos_map"]; name = "literal_date_map" },
-      variety = "map";
-      ancestors = ["Marked.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 }
+  | Exists of { predicate : lident Mark.pos * expression }
-  | Forall of { predicate : lident Marked.pos * expression }
+  | Forall of { predicate : lident Mark.pos * expression }
-  | Map of { f : lident Marked.pos * expression }
+  | Map of { f : lident Mark.pos * expression }
-  | Filter of { f : lident Marked.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 match_cases = match_case Mark.pos list
-and expression = naked_expression Marked.pos
+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
+  | Binop of binop Mark.pos * expression * expression
-  | Unop of unop Marked.pos * 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
+      (path * uident Mark.pos) Mark.pos * (lident Mark.pos * expression) list
-      * (lident Marked.pos * expression) list
+  | LetIn of lident Mark.pos * expression * expression
-  | LetIn of lident Marked.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
+      (path * uident Mark.pos) Mark.pos * (lident Mark.pos * expression) list
-      * (lident Marked.pos * expression) list
   | ArrayLit of expression list
-  | Ident of path * lident Marked.pos
+  | Ident of path * lident Mark.pos
-  | Dotted of expression * (path * lident Marked.pos) Marked.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_consequence : (bool[@opaque]) Mark.pos;
-  rule_state : lident Marked.pos option;
+  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_name : scope_var Mark.pos;
-  definition_parameter : lident Marked.pos list Marked.pos option;
+  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_name : uident Mark.pos;
-  scope_use_items : scope_use_item Marked.pos list;
+  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_input : io_input Mark.pos;
-  scope_decl_context_io_output : bool Marked.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_name : lident Mark.pos;
-  scope_decl_context_scope_sub_scope : uident Marked.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";
+          "lident_map"; "uident_map"; "scope_decl_context_io_map"; "Mark.pos_map";
-          "uident_map";
-          "scope_decl_context_io_map";
-          "Marked.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_name : uident Mark.pos;
-  scope_decl_context : scope_decl_context_item Marked.pos list;
+  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_name : lident Mark.pos;
-  topdef_args :
+  topdef_args : (lident Mark.pos * base_typ Mark.pos) list Mark.pos option;
-    (lident Marked.pos * base_typ Marked.pos) list Marked.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 = ["Mark.pos_map"]; name = "source_repr_map" },
-      variety = "map";
-      ancestors = ["Marked.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 = ["Mark.pos_map"]; name = "law_heading_map" },
-      variety = "map";
-      ancestors = ["Marked.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
+  | PdfFile of (string[@opaque]) Mark.pos * (int[@opaque]) option
-  | CatalaFile of (string[@opaque]) Marked.pos
+  | CatalaFile of (string[@opaque]) Mark.pos
-  | LegislativeText of (string[@opaque]) Marked.pos
+  | LegislativeText of (string[@opaque]) Mark.pos
 [@@deriving
   visitors
-    {
+    { variety = "map"; ancestors = ["Mark.pos_map"]; name = "law_include_map" },
-      variety = "map";
-      ancestors = ["Marked.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 =
+  let consequence_expr = Literal (LBool (Mark.remove rule.rule_consequence)) in
-    Literal (LBool (Marked.unmark 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)
+    (args : (lident Mark.pos * base_typ Mark.pos) list Mark.pos option)
-    (return_typ : base_typ Marked.pos) : typ =
+    (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 })

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

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<Ast.uident Marked.pos> addpos(UIDENT)
+%type<Ast.uident Mark.pos> addpos(UIDENT)
 %type<Pos.t> pos(CONDITION)
 %type<Ast.primitive_typ> primitive_typ
 %type<Ast.base_typ_data> typ_data
 %type<Ast.base_typ> typ
-%type<Ast.uident Marked.pos> uident
+%type<Ast.uident Mark.pos> uident
-%type<Ast.lident Marked.pos> lident
+%type<Ast.lident Mark.pos> lident
 %type<Ast.scope_var> scope_var
-%type<Ast.path * Ast.uident Marked.pos> quident
+%type<Ast.path * Ast.uident Mark.pos> quident
-%type<Ast.path * Ast.lident Marked.pos> qlident
+%type<Ast.path * Ast.lident Mark.pos> qlident
 %type<Ast.expression> expression
 %type<Ast.naked_expression> naked_expression
-%type<Ast.lident Marked.pos * expression> struct_content_field
+%type<Ast.lident Mark.pos * expression> struct_content_field
 %type<Ast.naked_expression> struct_or_enum_inject
 %type<Ast.literal_number> num_literal
 %type<Ast.literal_unit> unit_literal
 %type<Ast.literal> literal
-%type<(Ast.lident Marked.pos * expression) list> scope_call_args
+%type<(Ast.lident Mark.pos * expression) list> scope_call_args
 %type<bool> minmax
 %type<Ast.unop> unop
 %type<Ast.binop> binop
 %type<Ast.match_case_pattern> constructor_binding
 %type<Ast.match_case> match_arm
 %type<Ast.expression> condition_consequence
-%type<Ast.scope_var Marked.pos * Ast.lident Marked.pos list Marked.pos option> rule_expr
+%type<Ast.scope_var Mark.pos * Ast.lident Mark.pos list Mark.pos option> rule_expr
 %type<bool> rule_consequence
 %type<Ast.rule> rule
-%type<Ast.lident Marked.pos list> definition_parameters
+%type<Ast.lident Mark.pos list> definition_parameters
-%type<Ast.lident Marked.pos> label
+%type<Ast.lident Mark.pos> label
-%type<Ast.lident Marked.pos> state
+%type<Ast.lident Mark.pos> state
 %type<Ast.exception_to> exception_to
 %type<Ast.definition> definition
 %type<Ast.variation_typ> variation_type
 %type<Ast.scope_use_item> assertion
-%type<Ast.scope_use_item Marked.pos> scope_item
+%type<Ast.scope_use_item Mark.pos> scope_item
-%type<Ast.lident Marked.pos * Ast.base_typ Marked.pos> struct_scope_base
+%type<Ast.lident Mark.pos * Ast.base_typ Mark.pos> struct_scope_base
 %type<Ast.struct_decl_field> struct_scope
 %type<Ast.io_input> scope_decl_item_attribute_input
 %type<bool> scope_decl_item_attribute_output
@@ -91,7 +91,7 @@ end>
 %type<Ast.enum_decl_case> enum_decl_line
 %type<Ast.code_item> code_item
 %type<Ast.code_block> code
-%type<Ast.code_block * string Marked.pos> metadata_block
+%type<Ast.code_block * string Mark.pos> metadata_block
 %type<Ast.law_heading> law_heading
 %type<string> law_text
 %type<Ast.law_structure> source_file_item
@@ -157,7 +157,7 @@ let expression :=
 
 let naked_expression ==
 | id = addpos(LIDENT) ; {
-  match Localisation.lex_builtin (Marked.unmark id) with
+  match Localisation.lex_builtin (Mark.remove id) with
   | Some b -> Builtin b
   | None -> Ident ([], id)
 }
@@ -204,7 +204,7 @@ let naked_expression ==
 } %prec apply
 | SUM ; typ = addpos(primitive_typ) ;
   OF ; coll = expression ; {
-  CollectionOp (AggregateSum { typ = Marked.unmark typ }, coll)
+  CollectionOp (AggregateSum { typ = Mark.remove typ }, coll)
 } %prec apply
 | f = expression ;
   FOR ; i = lident ;
@@ -392,14 +392,14 @@ let rule :=
   cond = option(condition_consequence) ;
   consequence = addpos(rule_consequence) ; {
   let (name, params_applied) = name_and_param in
-  let cons : bool Marked.pos = consequence in
+  let cons : bool Mark.pos = consequence in
   let rule_exception = match except with
     | None -> NotAnException
-    | Some x -> Marked.unmark x
+    | Some x -> Mark.remove x
   in
   let pos_start =
-    match label with Some l -> Marked.get_mark l
+    match label with Some l -> Mark.get l
-    | None -> match except with Some e -> Marked.get_mark e
+    | 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)),
+      (String.concat "." (List.map (fun i -> Mark.remove i) (Mark.remove name)),
-       Pos.join pos_start (Marked.get_mark 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)),
+        (String.concat "." (List.map (fun i -> Mark.remove i) (Mark.remove name)),
-         Pos.join pos_start (Marked.get_mark 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 =

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 =
+        let sub_source = Filename.concat source_dir (Mark.remove sub_source) in
-          Filename.concat source_dir (Marked.unmark sub_source)
-        in
         let includ_program = parse_source_file (FileName sub_source) language in
         {
           Ast.program_source_files =

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
+      path (Mark.remove constructor)
-      (Marked.unmark constructor)

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)
+      (Mark.get e)
-  | EEmptyError -> Marked.same_mark_as (ELit (LBool false)) 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
+                        match Mark.remove body with
-                        | EEmptyError ->
+                        | EEmptyError -> Mark.copy field (ELit (LBool true))
-                          Marked.same_mark_as (ELit (LBool true)) field
                         | _ ->
                           (* same as basic [EAbs case]*)
                           generate_vc_must_not_return_empty ctx field)
@@ -236,13 +235,13 @@ let rec generate_vc_must_not_return_empty (ctx : ctx) (e : typed expr) :
                     (StructField.Map.bindings fields)
                 | _ -> [generate_vc_must_not_return_empty ctx arg])
               args))
-      (Marked.get_mark e)
+      (Mark.get e)
   | _ ->
     conjunction
       (Expr.shallow_fold
          (fun e acc -> generate_vc_must_not_return_empty ctx e :: acc)
          e [])
-      (Marked.get_mark e)
+      (Mark.get e)
 
 (** [generate_vc_must_not_return_conflict e] returns the dcalc boolean
     expression [b] such that if [b] is true, then [e] will never return a
@@ -252,11 +251,11 @@ let rec generate_vc_must_not_return_conflict (ctx : ctx) (e : typed expr) :
     vc_return =
   (* See the code of [generate_vc_must_not_return_empty] for a list of
      invariants on which this function relies on. *)
-  match Marked.unmark e with
+  match Mark.remove e with
   | EAbs { binder; _ } ->
     let _vars, body = Bindlib.unmbind binder in
     (generate_vc_must_not_return_conflict ctx) body
-  | EVar _ | ELit _ | EOp _ -> Marked.same_mark_as (ELit (LBool true)) e
+  | EVar _ | ELit _ | EOp _ -> Mark.copy e (ELit (LBool true))
   | EDefault { excepts; just; cons } ->
     (* <e1 ... en | ejust :- econs > never returns conflict if and only if: -
        neither e1 nor ... nor en nor ejust nor econs return conflict - there is
@@ -271,24 +270,24 @@ let rec generate_vc_must_not_return_conflict (ctx : ctx) (e : typed expr) :
                     generate_vc_must_not_return_empty ctx e1;
                     generate_vc_must_not_return_empty ctx e2;
                   ]
-                  (Marked.get_mark e))
+                  (Mark.get e))
               (half_product excepts excepts))
-           (Marked.get_mark e))
+           (Mark.get e))
-        (Marked.get_mark 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 = Mark.add Pos.no_pos (TLit TBool) })
-                     pos = Pos.no_pos;
-                     ty = Marked.mark 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

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 :

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)))
+             (Bindlib.name_of (Mark.remove vc.vc_variable)))
-          (Pos.retrieve_loc_text (Marked.get_mark 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)))
+             (Bindlib.name_of (Mark.remove vc.vc_variable)))
-          (Pos.retrieve_loc_text (Marked.get_mark 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

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 name = Mark.remove (EnumConstructor.get_info name) in
-    let ctx, arg_z3_ty = translate_typ ctx (Marked.unmark ty) 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 (Typed { ty = match_ty; _ }) = Mark.get vc in
-    let ctx, z3_ty = translate_typ ctx (Marked.unmark match_ty) 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

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 -> ""