Implement message subsets.

compiler/gencode.ml

@@ -180,7 +180,7 @@ let poly_beta_reduce_texpr bindings : type_expr -> poly_type_expr = function
   | `Record (r, opts) -> beta_reduce_record reduce_to_poly_texpr_core bindings r opts
   | #base_type_expr as x -> (reduce_to_poly_texpr_core bindings x :> poly_type_expr)
 
-let map_message bindings (f : base_type_expr -> _) g msgname msg =
+let map_message bindings (f : base_type_expr -> _) g msgname (msg : message_expr) =
   let map_field f (fname, mutabl, ty) = (fname, mutabl, f ty) in
   let expand_record_type f name ty =
     match beta_reduce_texpr bindings ty with
@@ -191,23 +191,31 @@ let map_message bindings (f : base_type_expr -> _) g msgname msg =
              assert false
   in
   match msg with
-  | `Sum cases  ->
+  | `Message_sum cases  ->
       Message_sum
         (List.map
            (function
-                (const, `Record fields) -> (None, const, List.map (map_field f) fields)
-              | (const, (`App (name, _args, _opts) as ty)) ->
+                (const, `Message_record fields) -> (None, const, List.map (map_field f) fields)
+              | (const, (`Message_app (name, _args, _opts))) ->
                   expand_record_type
                     (fun r _opts -> (Some name, const, List.map (map_field g) r.record_fields))
-                    name ty)
+                    name (`App (name, _args, _opts)))
            cases)
-  | `Record fields -> Message_single (None, List.map (map_field f) fields)
-  | `App (name, _args, _opts) as ty ->
+  | `Message_record fields -> Message_single (None, List.map (map_field f) fields)
+  | `Message_app (name, _args, _opts) ->
       expand_record_type
         (fun r _opts ->
             Message_single (Some r.record_name, List.map (map_field g) r.record_fields))
-        name ty
+        name (`App (name, _args, _opts))
   | `Message_alias (path, name) -> Message_alias (path, name)
+  | `Message_subset (name, excluded) ->
+      match smap_find name bindings with
+        | Some (Message_decl (_, `Message_record fields, _opts)) ->
+            Message_subset (name, List.map (map_field f) fields, excluded)
+        | None | Some _ ->
+            failwithfmt
+              "wrong message subset: %s is not a simple message" name;
+            assert false
 
 let iter_message bindings f g msgname msg =
   let proc_field f const (fname, mutabl, ty) = f const fname mutabl ty in
@@ -221,15 +229,16 @@ let iter_message bindings f g msgname msg =
               assert false
   in
   match msg with
-  | `Sum cases  ->
+  | `Message_sum cases  ->
         List.iter
           (function
-               (const, `Record fields) -> List.iter (proc_field f const) fields
-             | (const, (`App (name, _args, _opts) as ty)) ->
-                 iter_expanded_type const name ty)
+               (const, `Message_record fields) -> List.iter (proc_field f const) fields
+             | (const, (`Message_app (name, _args, _opts))) ->
+                 iter_expanded_type const name (`App (name, _args, _opts)))
           cases
-  | `Record fields -> List.iter (proc_field f "") fields
-  | `App(name, _args, _opts) as ty -> iter_expanded_type "" name ty
+  | `Message_record fields -> List.iter (proc_field f "") fields
+  | `Message_app(name, _args, _opts) ->
+      iter_expanded_type "" name (`App (name, _args, _opts))
 
 let low_level_msg_def bindings msgname (msg : message_expr) =
 

compiler/gencode_types.ml

@@ -25,11 +25,17 @@ and field = {
 }
 
 and 'a message =
-  | Message_single of string option * (string * bool * 'a) list
-    (* namespace (for poly record types) * list of  constructor * mutable * type *)
-  | Message_sum of (string option * string * (string * bool * 'a) list) list
-    (* list of  namespace * constructor * list of fields as above *)
+  | Message_single of namespace option * (field_name * field_mutable * 'a) list
+  | Message_sum of (namespace option * constructor_name * (field_name * field_mutable * 'a) list) list
   | Message_alias of string list * string (* path * name *)
+  | Message_subset of msg_name * (field_name * field_mutable * 'a) list * chosen_field list
+
+and namespace        = string
+and constructor_name = string
+and msg_name         = string
+and field_name       = string
+and field_mutable    = bool
+and chosen_field     = field_name
 
 and vint_meaning =
     Bool

compiler/parser.ml

@@ -18,7 +18,7 @@ let sum_of_constructor_list l =
 
 let make_complex_msg_expr n = function
     `Alias (p, name)  -> `Message_alias (n :: p, name)
-  | `Sum (x, l) -> `Sum ((n, x) :: l)
+  | `Sum (x, l) -> `Message_sum ((n, x) :: l)
 
 EXTEND Gram
   GLOBAL: entries;
@@ -110,19 +110,23 @@ EXTEND Gram
 
   record_app :
     [ [ n = a_LIDENT; "<"; targs = LIST1 [ type_expr_simple ] SEP ","; ">" ->
-        `App (n, targs, [])
-      | n = a_LIDENT -> `App (n, [], []) ] ];
+        `Message_app (n, targs, [])
+      | n = a_LIDENT -> `Message_app (n, [], [])
+      ] ];
 
   record :
-    [ [ "{"; l = field_list; "}" -> `Record l ] ];
+    [ [ "{"; l = field_list; "}" -> `Message_record l
+      ] ];
 
   record_or_app :
     [ [ r = record -> r
       | r = record_app -> r ] ];
 
   msg_expr :
     [ [ r = record_or_app -> (r :> message_expr)
-      | n = a_UIDENT; x = complex_msg_expr -> make_complex_msg_expr n x ] ];
+      | n = a_UIDENT; x = complex_msg_expr -> make_complex_msg_expr n x
+      | "{|"; n = a_LIDENT; "only"; l = LIST1 [ a_LIDENT ] SEP ";"; "|}" -> `Message_subset (n, l)
+      ] ];
 
   complex_msg_expr:
     [ [ "."; l = LIST0 [ n = a_UIDENT -> n ] SEP "."; name = a_LIDENT ->

compiler/protocol_types.ml

@@ -91,22 +91,24 @@ let kind_of_type_expr = function
 | `Record -> "record"
 | `Sum -> "union"
 
-type base_message_expr = [ `Record of (string * bool * base_type_expr) list ]
+type base_message_expr = [ `Message_record of (string * bool * base_type_expr) list ]
 
-type message_expr_app = [ `App of string * base_type_expr list * type_options ]
+type message_expr_app = [ `Message_app of string * base_type_expr list * type_options ]
 
 type message_expr = [
     base_message_expr
   | message_expr_app
   | `Message_alias of string list * string
-  | `Sum of (string * [base_message_expr | message_expr_app]) list
+  | `Message_sum of (string * [base_message_expr | message_expr_app]) list
+  | `Message_subset of string * string list
 ]
 
 let kind_of_message_expr = function
-| `Record _ -> "record"
-| `App _ -> "application"
+| `Message_record _ -> "record"
+| `Message_app _ -> "application"
 | `Message_alias -> "message alias"
-| `Sum -> "union"
+| `Message_sum -> "union"
+| `Message_subset -> "subset"
 
 type declaration =
     Message_decl of string * message_expr * type_options

compiler/ptypes.ml

@@ -43,12 +43,12 @@ let free_type_variables decl : string list =
           (non_constant_constructors sum) in
 
   let rec msg_free_vars known = function
-    | `App (_, targs, _) ->
+    | `Message_app (_, targs, _) ->
         concat_map (fun ty -> type_free_vars known (ty :> type_expr)) targs
-    | `Record l ->
+    | `Message_record l ->
         concat_map (fun (_, _, e) -> type_free_vars known (e :> type_expr)) l
-    | `Message_alias _ -> []
-    | `Sum l ->
+    | `Message_subset _ | `Message_alias _ -> []
+    | `Message_sum l ->
         concat_map (fun (_, e) -> msg_free_vars known (e :> message_expr)) l in
 
   match decl with
@@ -104,17 +104,17 @@ let check_declarations decls =
                 in List.fold_left fold_base_ty acc params in
 
           let rec fold_msg acc : message_expr -> error list = function
-              `Record l ->
+            | `Message_record l ->
                 List.fold_left (fun errs (_, _, ty) -> fold_base_ty errs ty) acc l
-            | `Message_alias _ -> acc
-            | `App (s, params, _) ->
+            | `Message_subset _ | `Message_alias _ -> acc
+            | `Message_app (s, params, _) ->
                 let expected = List.length params in
                 let acc = match smap_find s arities with
                     None -> acc
                   | Some n when n = expected -> acc
                   | Some n -> Wrong_arity (s, n, name, expected) :: acc
                 in List.fold_left fold_base_ty acc params
-            | `Sum l ->
+            | `Message_sum l ->
                 List.fold_left
                   (fun errs (_, msg) -> fold_msg errs (msg :> message_expr))
                   acc l in

runtime/reader.ml

@@ -38,16 +38,17 @@ end
 
 type reader_func =
     [
-      `Offset | `Skip_to | `Read_prefix
+      | `Offset | `Skip_to | `Read_prefix | `Skip_value
       | `Read_vint | `Read_bool | `Read_rel_int | `Read_i8
       | `Read_i32 | `Read_i64 | `Read_float | `Read_string
       | `Read_raw_bool | `Read_raw_rel_int | `Read_raw_i8
       | `Read_raw_i32 | `Read_raw_i64 | `Read_raw_float | `Read_raw_string
     ]
 
 let string_of_reader_func : reader_func -> string = function
-  `Offset -> "offset"
+  | `Offset -> "offset"
   | `Skip_to -> "skip_to"
+  | `Skip_value -> "skip_value"
   | `Read_prefix -> "read_prefix"
   | `Read_vint -> "read_vint"
   | `Read_bool -> "read_bool"

runtime/reader.mli

@@ -44,7 +44,8 @@ type reader_func =
     | `Read_rel_int
     | `Read_string
     | `Read_vint
-    | `Skip_to ]
+    | `Skip_to
+    | `Skip_value ]
 
 val string_of_reader_func : reader_func -> string