Separate ops building from code generation

Author: emillon

ppx/ppx_cstruct.ml

@@ -150,67 +150,51 @@ let op_name s op =
 
 let op_pvar s op = Ast.pvar (op_name s op)
 let op_evar s op = Ast.evar (op_name s op)
-let op_val_typ loc s op ty =
-  Sig.value (Val.mk (Loc.mkloc (op_name s op) loc) ty)
 
-let output_get _loc s f =
-  let m = mode_mod _loc s.endian in
+let get_expr loc s f =
+  let m = mode_mod loc s.endian in
   let num x = Ast.int x in
   match f.ty with
   |Buffer (_, _) ->
     let len = width_of_field f in
-    [%str
-      let [%p op_pvar s (Op_get f)] =
-        fun src -> Cstruct.sub src [%e num f.off] [%e num len]
-
-      let[@ocaml.warning "-32"] [%p op_pvar s (Op_copy f)] =
-        fun src -> Cstruct.copy src [%e num f.off] [%e num len]
+    [%expr
+      fun src -> Cstruct.sub src [%e num f.off] [%e num len]
     ]
   |Prim prim ->
-    [%str
-      let [%p op_pvar s (Op_get f)] = fun v ->
+    [%expr
+      fun v ->
         [%e match prim with
             |Char -> [%expr Cstruct.get_char v [%e num f.off]]
             |UInt8 -> [%expr Cstruct.get_uint8 v [%e num f.off]]
             |UInt16 -> [%expr [%e m "get_uint16"] v [%e num f.off]]
             |UInt32 -> [%expr [%e m "get_uint32"] v [%e num f.off]]
             |UInt64 -> [%expr [%e m "get_uint64"] v [%e num f.off]]]]
 
-let output_get loc s f =
-  (output_get loc s f) [@metaloc loc]
-
 let type_of_int_field = function
   |Char -> [%type: char]
   |UInt8 -> [%type: Cstruct.uint8]
   |UInt16 -> [%type: Cstruct.uint16]
   |UInt32 -> [%type: Cstruct.uint32]
   |UInt64 -> [%type: Cstruct.uint64]
 
-let output_set _loc s f =
-  let m = mode_mod _loc s.endian in
+let set_expr loc s f =
+  let m = mode_mod loc s.endian in
   let num x = Ast.int x in
   match f.ty with
   |Buffer (_,_) ->
     let len = width_of_field f in
-    [%str
-      let[@ocaml.warning "-32"] [%p op_pvar s (Op_set f)] = fun src srcoff dst ->
-        Cstruct.blit_from_string src srcoff dst [%e num f.off] [%e num len]
-
-      let[@ocaml.warning "-32"] [%p op_pvar s (Op_blit f)] = fun src srcoff dst ->
-        Cstruct.blit src srcoff dst [%e num f.off] [%e num len]]
+    [%expr
+      fun src srcoff dst ->
+        Cstruct.blit_from_string src srcoff dst [%e num f.off] [%e num len]]
   |Prim prim ->
-    [%str
-      let[@ocaml.warning "-32"] [%p op_pvar s (Op_set f)] = fun v x ->
+    [%expr fun v x ->
         [%e match prim with
             |Char -> [%expr Cstruct.set_char v [%e num f.off] x]
             |UInt8 -> [%expr Cstruct.set_uint8 v [%e num f.off] x]
             |UInt16 -> [%expr [%e m "set_uint16"] v [%e num f.off] x]
             |UInt32 -> [%expr [%e m "set_uint32"] v [%e num f.off] x]
             |UInt64 -> [%expr [%e m "set_uint64"] v [%e num f.off] x]]]
 
-let output_set _loc s f =
-  output_set _loc s f [@metaloc _loc]
-
 let type_of_set f =
   match f.ty with
   |Buffer (_,_) ->
@@ -219,52 +203,84 @@ let type_of_set f =
     let retf = type_of_int_field prim in
     [%type: Cstruct.t -> [%t retf] -> unit]
 
-let output_sizeof _loc s =
-  [%stri
-    let [%p op_pvar s Op_sizeof] = [%e Ast.int s.len]] [@metaloc _loc]
+let hexdump_expr s =
+  [%expr fun v ->
+    let buf = Buffer.create 128 in
+    Buffer.add_string buf [%e Ast.str (s.name ^ " = {\n")];
+    [%e op_evar s Op_hexdump_to_buffer] buf v;
+    print_endline (Buffer.contents buf);
+    print_endline "}"
+  ]
 
-let output_hexdump _loc s =
+let hexdump_to_buffer_expr s =
   let hexdump =
     List.fold_left (fun a f ->
         let get_f = op_evar s (Op_get f) in
         [%expr
-          [%e a]; Buffer.add_string _buf [%e Ast.str ("  "^f.field^" = ")];
+          [%e a]; Buffer.add_string buf [%e Ast.str ("  "^f.field^" = ")];
           [%e match f.ty with
               |Prim Char ->
-                [%expr Printf.bprintf _buf "%c\n" ([%e get_f] v)]
+                [%expr Printf.bprintf buf "%c\n" ([%e get_f] v)]
               |Prim (UInt8|UInt16) ->
-                [%expr Printf.bprintf _buf "0x%x\n" ([%e get_f] v)]
+                [%expr Printf.bprintf buf "0x%x\n" ([%e get_f] v)]
               |Prim UInt32 ->
-                [%expr Printf.bprintf _buf "0x%lx\n" ([%e get_f] v)]
+                [%expr Printf.bprintf buf "0x%lx\n" ([%e get_f] v)]
               |Prim UInt64 ->
-                [%expr Printf.bprintf _buf "0x%Lx\n" ([%e get_f] v)]
+                [%expr Printf.bprintf buf "0x%Lx\n" ([%e get_f] v)]
               |Buffer (_,_) ->
-                [%expr Printf.bprintf _buf "<buffer %s>"
+                [%expr Printf.bprintf buf "<buffer %s>"
                          [%e Ast.str (field_to_string f)];
-                         Cstruct.hexdump_to_buffer _buf ([%e get_f] v)]
+                         Cstruct.hexdump_to_buffer buf ([%e get_f] v)]
           ]]
       ) (Ast.unit ()) s.fields
   in
-  [
-    [%stri
-      let [%p op_pvar s Op_hexdump_to_buffer] = fun _buf v ->
-        [%e hexdump]];
-    [%stri
-      let[@ocaml.warning "-32"] [%p op_pvar s Op_hexdump] = fun v ->
-        let _buf = Buffer.create 128 in
-        Buffer.add_string _buf [%e Ast.str (s.name ^ " = {\n")];
-        [%e op_evar s Op_hexdump_to_buffer] _buf v;
-        print_endline (Buffer.contents _buf);
-        print_endline "}"
-    ]
-  ] [@metaloc _loc]
+  [%expr fun buf v -> [%e hexdump]]
+
+let op_expr loc s = function
+  | Op_sizeof -> Ast.int s.len
+  | Op_hexdump -> hexdump_expr s
+  | Op_hexdump_to_buffer -> hexdump_to_buffer_expr s
+  | Op_get f -> get_expr loc s f
+  | Op_set f -> set_expr loc s f
+  | Op_copy f ->
+    let len = width_of_field f in
+    [%expr fun src -> Cstruct.copy src [%e Ast.int f.off] [%e Ast.int len] ]
+  | Op_blit f ->
+    let len = width_of_field f in
+    [%expr fun src srcoff dst ->
+      Cstruct.blit src srcoff dst [%e Ast.int f.off] [%e Ast.int len]]
 
-let output_struct_one_endian _loc s =
-  (* Generate functions of the form {get/set}_<struct>_<field> *)
-  let expr = List.fold_left (fun a f ->
-      a @ output_get _loc s f @ output_set _loc s f
-    ) [output_sizeof _loc s] s.fields
-  in expr @ output_hexdump _loc s
+let ops_for s =
+  let field_ops =
+    List.concat (
+      List.map (fun f ->
+        let if_buffer x =
+          match f.ty with
+          |Buffer (_,_) -> [x]
+          |Prim _ -> []
+        in
+        List.concat
+          [ [Op_get f]
+          ; if_buffer (Op_copy f)
+          ; [Op_set f]
+          ; if_buffer (Op_blit f)
+          ]
+      ) s.fields
+    )
+  in
+  ( [Op_sizeof]
+  @ field_ops
+  @ [Op_hexdump_to_buffer;
+     Op_hexdump;
+    ])
+
+(** Generate functions of the form {get/set}_<struct>_<field> *)
+let output_struct_one_endian loc s =
+  List.map
+    (fun op ->
+       [%stri let[@ocaml.warning "-32"] [%p op_pvar s op] =
+                [%e op_expr loc s op]])
+    (ops_for s)
 
 let output_struct _loc s =
   match s.endian with
@@ -301,30 +317,13 @@ let op_typ = function
 
 (** Generate signatures of the form {get/set}_<struct>_<field> *)
 let output_struct_sig loc s =
-  let field_ops =
-    List.concat (
-      List.map (fun f ->
-        let if_buffer x =
-          match f.ty with
-          |Buffer (_,_) -> [x]
-          |Prim _ -> []
-        in
-        List.concat
-          [ [Op_get f]
-          ; if_buffer (Op_copy f)
-          ; [Op_set f]
-          ; if_buffer (Op_blit f)
-          ]
-      ) s.fields
-    )
-  in
   List.map
-    (fun op -> op_val_typ loc s op (op_typ op))
-    ( [Op_sizeof]
-    @ field_ops
-    @ [Op_hexdump_to_buffer;
-       Op_hexdump;
-      ])
+    (fun op ->
+       Sig.value
+         (Val.mk
+            (Loc.mkloc (op_name s op) loc)
+            (op_typ op)))
+    (ops_for s)
 
 let output_enum _loc name fields width ~sexp =
   let intfn,pattfn = match ty_of_string width with