better interface fox Indexed

src/assigned.ml

@@ -52,9 +52,7 @@ let assign_type (acc : type_acc) (name, sub_type) : type_acc Result.t =
     let+ str_type = Simplified_types.convert_str None str_type in
     let id = last_assigned_int in
     let last_assigned_int = succ last_assigned_int in
-    let declared_types =
-      { Indexed.index = id; value = str_type } :: declared_types
-    in
+    let declared_types = Indexed.return id str_type :: declared_types in
     let named_types =
       match name with
       | None -> named_types
@@ -79,7 +77,7 @@ let assign_heap_type (acc : type_acc) typ : type_acc Result.t =
     let all_types = TypeMap.add typ id all_types in
     let func_types =
       match typ with
-      | Def_func_t _ftype -> { Indexed.index = id; value = typ } :: func_types
+      | Def_func_t _ftype -> Indexed.return id typ :: func_types
       | Def_array_t (_mut, _storage_type) -> func_types
       | Def_struct_t _ -> func_types
     in
@@ -109,11 +107,13 @@ let get_runtime_name (get_name : 'a -> string option) (elt : ('a, 'b) Runtime.t)
 
 let name kind ~get_name values =
   let assign_one (named : int String_map.t) (elt : _ Indexed.t) =
-    match get_name elt.value with
+    let elt_v = Indexed.get elt in
+    match get_name elt_v with
     | None -> Ok named
     | Some name ->
+      let index = Indexed.get_index elt in
       if String_map.mem name named then error_s "duplicate %s %s" kind name
-      else ok @@ String_map.add name elt.index named
+      else ok @@ String_map.add name index named
   in
   let+ named = list_fold_left assign_one String_map.empty values in
   { Named.values; named }
@@ -129,9 +129,9 @@ let check_type_id (types : str_type Named.t) (check : Grouped.type_check) =
       | Some t -> Ok t )
   in
   (* TODO more efficient version of that *)
-  match List.find_opt (fun v -> v.Indexed.index = id) types.values with
+  match Indexed.get_at id types.values with
   | None -> Error "unknown type"
-  | Some { value = Def_func_t func_type'; _ } ->
+  | Some (Def_func_t func_type') ->
     let* func_type = Simplified_types.convert_func_type None func_type in
     if not (equal_func_types func_type func_type') then
       Error "inline function type"

src/grouped.ml

@@ -77,32 +77,32 @@ let init_curr = { global = 0; table = 0; mem = 0; func = 0; elem = 0; data = 0 }
 
 let add_global value (fields : t) (curr : curr) =
   let index = curr.global in
-  ( { fields with global = { index; value } :: fields.global }
+  ( { fields with global = Indexed.return index value :: fields.global }
   , { curr with global = succ curr.global } )
 
 let add_table value (fields : t) (curr : curr) =
   let index = curr.table in
-  ( { fields with table = { index; value } :: fields.table }
+  ( { fields with table = Indexed.return index value :: fields.table }
   , { curr with table = succ curr.table } )
 
 let add_mem value (fields : t) (curr : curr) =
   let index = curr.mem in
-  ( { fields with mem = { index; value } :: fields.mem }
+  ( { fields with mem = Indexed.return index value :: fields.mem }
   , { curr with mem = succ curr.mem } )
 
 let add_func value (fields : t) (curr : curr) =
   let index = curr.func in
-  ( { fields with func = { index; value } :: fields.func }
+  ( { fields with func = Indexed.return index value :: fields.func }
   , { curr with func = succ curr.func } )
 
 let add_elem value (fields : t) (curr : curr) =
   let index = curr.elem in
-  ( { fields with elem = { index; value } :: fields.elem }
+  ( { fields with elem = Indexed.return index value :: fields.elem }
   , { curr with elem = succ curr.elem } )
 
 let add_data value (fields : t) (curr : curr) =
   let index = curr.data in
-  ( { fields with data = { index; value } :: fields.data }
+  ( { fields with data = Indexed.return index value :: fields.data }
   , { curr with data = succ curr.data } )
 
 let check_limit { min; max } =
@@ -184,7 +184,8 @@ let of_symbolic (modul : Symbolic.modul) : t Result.t =
           (typ :: fields.function_type, type_checks)
       in
       let index = curr.func in
-      let func = { Indexed.value = Runtime.Local func; index } :: fields.func in
+      let value = Runtime.Local func in
+      let func = Indexed.return index value :: fields.func in
       Ok
         ( { fields with func; function_type; type_checks }
         , { curr with func = succ curr.func } )

src/indexed.ml

@@ -7,10 +7,25 @@ type 'a t =
   ; value : 'a
   }
 
+let get v = v.value
+
+let get_index v = v.index
+
+let bind v f = f v.value
+
+let map f v = { index = v.index; value = f v.value }
+
+let return index value = { index; value }
+
 let has_index idx { index; _ } = idx = index
 
-let get_at i values =
+let get_at_exn i values =
   let { value; _ } = List.find (has_index i) values in
   value
 
+let get_at i values =
+  match List.find_opt (has_index i) values with
+  | None -> None
+  | Some { value; _ } -> Some value
+
 let pp f fmt v = Format.fprintf fmt "%a" f v.value

src/indexed.mli

@@ -0,0 +1,14 @@
+type 'a t
+
+val get : 'a t -> 'a
+val get_index : 'a t -> int
+val bind : 'a t -> ('a -> 'b t) -> 'b t
+val map : ('a -> 'b) -> 'a t -> 'b t
+val return : int -> 'a -> 'a t
+
+
+val get_at : int -> 'a t list -> 'a option
+val get_at_exn : int -> 'a t list -> 'a
+val has_index : int -> 'a t -> bool
+
+val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit

src/named.ml

@@ -2,18 +2,19 @@
 (* Copyright © 2021 Léo Andrès *)
 (* Copyright © 2021 Pierre Chambart *)
 
-open Indexed
-
 (** named values (fields) *)
 type 'a t =
   { values : 'a Indexed.t list
   ; named : int String_map.t
   }
 
 let fold f v acc =
-  List.fold_left (fun acc v -> f v.index v.value acc) acc v.values
+  List.fold_left
+    (fun acc v -> f (Indexed.get_index v) (Indexed.get v) acc)
+    acc v.values
 
-let iter f v = List.iter (fun v -> f v.index v.value) v.values
+let iter f v =
+  List.iter (fun v -> f (Indexed.get_index v) (Indexed.get v)) v.values
 
 let map f v =
   let values = List.map f v.values in

src/optimize.ml

@@ -370,12 +370,11 @@ let optimize_func func =
   { type_f; locals; body; id }
 
 let optimize_runtime_func f =
-  let { Indexed.value; Indexed.index } = f in
-  match value with
-  | Runtime.Imported _ -> f
-  | Local f ->
-    let value = Runtime.Local (optimize_func f) in
-    { value; index }
+  Indexed.map
+    (function
+      | Runtime.Imported _ as f -> f
+      | Local f -> Runtime.Local (optimize_func f) )
+    f
 
 let optimize_funcs funs = Named.map optimize_runtime_func funs
 

src/rewrite.ml

@@ -33,7 +33,7 @@ let find_global (modul : Assigned.t) ~imported_only id : (int * mut) Result.t =
   let* idx = find "unknown global" modul.global id in
   let va = List.find (Indexed.has_index idx) modul.global.values in
   let+ mut, _typ =
-    match va.value with
+    match Indexed.get va with
     | Imported imported -> Ok imported.desc
     | Local global ->
       if imported_only then Error "unknown global"
@@ -73,10 +73,10 @@ let rewrite_expr (modul : Assigned.t) (locals : param list)
 
   let bt_some_to_raw : Symbolic.block_type -> block_type Result.t = function
     | Symbolic.Arg.Bt_ind ind -> begin
-      match get "unknown type" modul.typ (Some ind) with
-      | Ok { value = Def_func_t t'; _ } -> Ok t'
-      | Error _ as e -> e
-      | Ok _ -> Error "TODO: Simplify.bt_some_to_raw"
+      let* v = get "unknown type" modul.typ (Some ind) in
+      match Indexed.get v with
+      | Def_func_t t' -> Ok t'
+      | _ -> Error "TODO: Simplify.bt_some_to_raw"
     end
     | Bt_raw (type_use, t) -> (
       let* t = Simplified_types.convert_func_type None t in
@@ -85,10 +85,10 @@ let rewrite_expr (modul : Assigned.t) (locals : param list)
       | Some ind ->
         (* we check that the explicit type match the type_use, we have to remove parameters names to do so *)
         let* t' =
-          match get "unknown type" modul.typ (Some ind) with
-          | Ok { value = Def_func_t t'; _ } -> Ok t'
-          | Error _ as e -> e
-          | Ok _ -> Error "TODO: Simplify.bt_some_to_raw"
+          let* v = get "unknown type" modul.typ (Some ind) in
+          match Indexed.get v with
+          | Def_func_t t' -> Ok t'
+          | _ -> Error "TODO: Simplify.bt_some_to_raw"
         in
         let ok = Simplified_types.equal_func_types t t' in
         if not ok then Error "inline function type" else Ok t )
@@ -98,8 +98,8 @@ let rewrite_expr (modul : Assigned.t) (locals : param list)
     function
     | None -> Ok None
     | Some bt ->
-      let* raw = bt_some_to_raw bt in
-      Ok (Some raw)
+      let+ raw = bt_some_to_raw bt in
+      Some raw
   in
 
   let* locals, after_last_assigned_local =
@@ -428,10 +428,10 @@ let rewrite_block_type (modul : Assigned.t) (block_type : Symbolic.block_type) :
   block_type Result.t =
   match block_type with
   | Symbolic.Arg.Bt_ind id -> begin
-    match get "unknown type" modul.typ (Some id) with
-    | Ok { value = Def_func_t t'; _ } -> Ok t'
-    | Error _ as e -> e
-    | Ok _ -> Error "TODO: Simplify.bt_some_to_raw"
+    let* v = get "unknown type" modul.typ (Some id) in
+    match Indexed.get v with
+    | Def_func_t t' -> Ok t'
+    | _ -> Error "TODO: Simplify.bt_some_to_raw"
   end
   | Bt_raw (_, func_type) -> Simplified_types.convert_func_type None func_type
 
@@ -511,8 +511,10 @@ let rewrite_named f named =
   let+ values =
     list_map
       (fun ind ->
-        let+ value = f ind.Indexed.value in
-        { ind with value } )
+        let index = Indexed.get_index ind in
+        let value = Indexed.get ind in
+        let+ value = f value in
+        Indexed.return index value )
       named.Named.values
   in
   { named with Named.values }
@@ -544,7 +546,7 @@ let modul (modul : Assigned.t) : modul Result.t =
       let* idx = find "unknown function" func (Some start) in
       let va = List.find (Indexed.has_index idx) func.Named.values in
       let param_typ, result_typ =
-        match va.value with
+        match Indexed.get va with
         | Local func -> func.type_f
         | Imported imported -> imported.desc
       in

src/typecheck.ml

@@ -50,34 +50,34 @@ module Env = struct
   let local_get i env = match Index.Map.find i env.locals with v -> v
 
   let global_get i env =
-    let value = Indexed.get_at i env.globals.values in
+    let value = Indexed.get_at_exn i env.globals.values in
     let _mut, typ =
       match value with Local { typ; _ } -> typ | Runtime.Imported t -> t.desc
     in
     typ
 
   let func_get i env =
-    let value = Indexed.get_at i env.funcs.values in
+    let value = Indexed.get_at_exn i env.funcs.values in
     match value with
     | Local { type_f; _ } -> type_f
     | Runtime.Imported t -> t.desc
 
   let block_type_get i env = List.nth env.blocks i
 
   let table_type_get_from_module i (modul : Simplified.modul) =
-    let value = Indexed.get_at i modul.table.values in
+    let value = Indexed.get_at_exn i modul.table.values in
     match value with
     | Local table -> snd (snd table)
     | Runtime.Imported t -> snd t.desc
 
   let table_type_get i env =
-    let value = Indexed.get_at i env.tables.values in
+    let value = Indexed.get_at_exn i env.tables.values in
     match value with
     | Local table -> snd (snd table)
     | Runtime.Imported t -> snd t.desc
 
   let elem_type_get i env =
-    let value = Indexed.get_at i env.elems.values in
+    let value = Indexed.get_at_exn i env.elems.values in
     value.typ
 
   let make ~params ~locals ~globals ~funcs ~result_type ~tables ~elems ~refs =
@@ -538,7 +538,7 @@ let typecheck_const_instr (modul : modul) refs stack = function
     Hashtbl.add refs i ();
     Stack.push [ Ref_type Func_ht ] stack
   | Global_get i ->
-    let value = Indexed.get_at i modul.global.values in
+    let value = Indexed.get_at_exn i modul.global.values in
     let* _mut, typ =
       match value with
       | Local _ -> Error "unknown global"
@@ -563,7 +563,7 @@ let typecheck_const_expr (modul : modul) refs =
 
 let typecheck_global (modul : modul) refs
   (global : (global, global_type) Runtime.t Indexed.t) =
-  match global.value with
+  match Indexed.get global with
   | Imported _ -> Ok ()
   | Local { typ; init; _ } -> (
     let* real_type = typecheck_const_expr modul refs init in
@@ -578,7 +578,8 @@ let typecheck_global (modul : modul) refs
     | _whatever -> Error "type mismatch (typecheck_global wrong num)" )
 
 let typecheck_elem modul refs (elem : elem Indexed.t) =
-  let _null, expected_type = elem.value.typ in
+  let elem = Indexed.get elem in
+  let _null, expected_type = elem.typ in
   let* () =
     list_iter
       (fun init ->
@@ -589,9 +590,9 @@ let typecheck_elem modul refs (elem : elem Indexed.t) =
             Error "type mismatch (typecheck_elem)"
           else Ok ()
         | _whatever -> Error "type mismatch (typecheck_elem wrong num)" )
-      elem.value.init
+      elem.init
   in
-  match elem.value.mode with
+  match elem.mode with
   | Elem_passive | Elem_declarative -> Ok ()
   | Elem_active (None, _e) -> assert false
   | Elem_active (Some tbl_i, e) -> (
@@ -606,7 +607,8 @@ let typecheck_elem modul refs (elem : elem Indexed.t) =
       | _whatever -> Error "type mismatch (typecheck_elem)" )
 
 let typecheck_data modul refs (data : data Indexed.t) =
-  match data.value.mode with
+  let data = Indexed.get data in
+  match data.mode with
   | Data_passive -> Ok ()
   | Data_active (_i, e) -> (
     let* t = typecheck_const_expr modul refs e in