ocaml-cstruct-codegen / lib / cstruct_codegen.ml

type ftype =
  { getter : string
  ; setter : string
  ; sz : int
  ; ocamltype : string
  ; printer : string
  }
;

type cfielddef = { fname : string ; ftype : ftype }
;

type cstructdef = (string * list cfielddef)
;

value cstruct name fields = (name, fields)
;

value accessors_module = "ExtUnix.Specific.BA.LittleEndian"
;

value printers =
  [ ("int", "string_of_int")
  ; ("int64", "Int64.to_string")
  ]
;

value fld sz fn mlty =
  let fty =
    { getter = accessors_module ^ ".unsafe_get_" ^ fn
    ; setter = accessors_module ^ ".unsafe_set_" ^ fn
    ; sz = sz
    ; ocamltype = mlty
    ; printer =
        try
          List.assoc mlty printers
        with
        [ Not_found ->
            failwith ("can't find printer for OCaml type " ^ mlty)
        ]
    }
  in
    fun n ->
      { fname = n
      ; ftype = fty
      }
;

(*                   bytes
                     |  getter-setter
                     |  |        ocaml type
                     |  |        |            *)
value int8_t   = fld 1  "int8"   "int"
  and uint8_t  = fld 1  "uint8"  "int"
  and int16_t  = fld 2  "int16"  "int"
  and uint16_t = fld 2  "uint16" "int"
  and int31_t  = fld 4  "int31"  "int"
  and uint31_t = fld 4  "uint31" "int"
  and int32_t  = fld 4  "int32"  "int32"
  and uint32_t = fld 4  "uint32" "int32"
  and int64_t  = fld 8  "int64"  "int64"
;


(************************************************************)

open Printf
;

value module_ name sig_ struct_ =
  sprintf "\
 module %s\n\
\ :\n\
\  sig\n%s\
\  end\n\
\ =\n\
\  struct\n%s\
\  end\n\n"
    (String.capitalize name) sig_ struct_
;


value list_iteri f l =
  loop l 0
  where rec loop l i =
    match l with
    [ [] -> ()
    | [h :: t] -> (f i h; loop t (i+1))
    ]
;


value string_of_cstructdef (csname, csfields) =
  let sig__ = ref ""
  and str__ = ref "" in
  let add strref fmt =
    Printf.ksprintf
      (fun str ->
         strref.val :=
             strref.val
           ^ (if str = "" then "" else "    ")
           ^ str
           ^ "\n"
      )
      fmt
  in
  let str_ fmt = add str__ fmt
  and sig_ fmt = add sig__ fmt in
  let rec ident base =
    if List.exists (fun f -> base = f.fname) csfields
    then ident (base ^ "'")
    else base
  in
  let ident_t = ident "t" in
  let cur_ofs = ref 0 in
  let ba_type =
    "(char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t"
  and ba_create = "Bigarray.Array1.create Bigarray.char Bigarray.c_layout" in
  ( sig_ ""
  ; sig_ "(* Abstract data type to represent values of C-like structure '%s' *)"
      csname
  ; sig_ "type t"
  ; str_ "type t = %s" ba_type
  ; sig_ ""
  ; sig_ "(* size of structure [t] in bytes *)"
  ; sig_ "val sizeof : int"
  ; sig_ ""
  ; sig_ "(* Creates a value of type [t] on bigarray of size [sizeof]."
  ; sig_ "   one can modify bigarray, and these modifications will"
  ; sig_ "   affect fields of created value (they will be visible with"
  ; sig_ "   get_<field> or [dump])."
  ; sig_ "   Raises [Failure] on size mismatch. *)"
  ; sig_ "val of_bigarray : %s -> t" ba_type

  ; sig_ ""
  ; sig_ "(* [bigarray_of s] returns bigarray containing all fields of [s]"
  ; sig_ "   in C-like layout. *)"
  ; sig_ "val bigarray_of : t -> %s" ba_type
  ; str_ "let bigarray_of t = t"

  ; sig_ ""
  ; sig_ "(* [create ()] creates an uninitialized structure of type [t]."
  ; sig_ "   It can be useful when:"
  ; sig_ "   - one wants to set all fields manually with setters"
  ; sig_ "     (however consider [make] function below, it gives guarantees"
  ; sig_ "     that every field is initialized)"
  ; sig_ "   - one wants to modify structure's bigarray (returned by"
  ; sig_ "     [bigarray_of]): fill it from file, socket etc. *)"
  ; sig_ "val create : unit -> t"

  ; sig_ ""
  ; sig_ "(* getters and setters: *)"
  ; str_ ""
  ; let for_field { fname = fname ; ftype = ftype } =
      let getter = "get_" ^ fname
      and setter = "set_" ^ fname in
      ( sig_
          "val %s : t -> %s"
          getter ftype.ocamltype
      ; sig_
          "val %s : t -> %s -> unit"
          setter ftype.ocamltype
      ; str_
          "let %s t = %s t %i"
          getter ftype.getter cur_ofs.val
      ; str_
          "let %s t v = %s t %i v"
          setter ftype.setter cur_ofs.val
      ; cur_ofs.val := cur_ofs.val + ftype.sz
      )
    in
      List.iter for_field csfields

  ; str_ "let sizeof = %i" cur_ofs.val

  ; str_ ""
  ; str_ "let of_bigarray t ="
  ; str_ "  if Bigarray.Array1.dim t <> sizeof"
  ; str_ "  then failwith \"%s.of_bigarray: size doesn't match\""
                  (String.capitalize csname)
  ; str_ "  else t"

  ; str_ "let create () = %s sizeof" ba_create

  ; sig_ ""
  ; sig_ "(* makes a value of type [t] and initializes it with"
  ; sig_ "   field values passed as labelled arguments. *)"
  ; sig_ "val make : %st"
      (String.concat ""
         (List.map
            (fun fld ->
               fld.fname ^ ":" ^ fld.ftype.ocamltype ^ " -> "
            )
            csfields
         )
      )
  ; str_ ""
  ; str_ "let make %s ="
      (String.concat " " (List.map (fun f -> "~" ^ f.fname) csfields))
  ; str_ "  let %s = %s sizeof in" ident_t ba_create
  ; str_ "  ("
  ; List.iter
     (fun f -> str_ "    set_%s %s %s;" f.fname ident_t f.fname
     )
     csfields
  ; str_ "    %s" ident_t
  ; str_ "  )"

  ; sig_ ""
  ; sig_ "(* dumps a value of type [t] to string, result looks like"
  ; sig_ "   \"{ a=1 ; b=3456 }\" *)"
  ; sig_ "val dump : t -> string"
  ; str_ ""
  ; str_ "let dump t ="
  ; str_ "  let b = Buffer.create 50 in"
  ; str_ "  ("
  ; list_iteri
     (fun i f ->
        ( str_ "    Buffer.add_string b %S;"
            ((if i = 0 then "{ " else " ; ") ^ f.fname ^ "=")
        ; str_ "    Buffer.add_string b (%s (get_%s t));"
            f.ftype.printer f.fname
        )
     )
     csfields
  ; str_ "    Buffer.add_string b %S;" " }"
  ; str_ "    Buffer.contents b"
  ; str_ "  )"

  ; module_ csname sig__.val str__.val
  )
;

value codegen_cstruct outch (cs : cstructdef) =
  output_string outch (string_of_cstructdef cs)
;


value codegen filename cstructs =
  let outch = open_out filename in
  let () = List.iter (codegen_cstruct outch) cstructs in
  close_out outch
;
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.