Commits

Dmitry Grebeniuk  committed 0ae9c52

+ enum support

  • Participants
  • Parent commits d73ef9c

Comments (0)

Files changed (6)

 # OASIS_STOP
 
 test1: all
-	./test1.byte
+	env OCAMLRUNPARAM=b ./test1.byte
 add new features to ocaml-cstruct, and decided to write his own
 implementation instead.
 
-  Here is how they compare:
+
+        Here is how they compare:
 
   Pros:
-- ocaml-cstruct-codegen doesn't use Camlp4, it uses code generation
-  (so people who don't want to learn Camlp4 can improve this library)
-- typing: every structure has its own abstract type, so it's impossible
-  to use a structure getter/setter on another structure (with different
-  layout; so with different type)
-- guarantees of full initialization of structures (when it's needed)
-- can dump structures to human-readable strings
+  - ocaml-cstruct-codegen doesn't use Camlp4, it uses code generation
+    (so people who don't want to learn Camlp4 can improve this library)
+  - typing: every structure has its own abstract type, so it's impossible
+    to use a structure getter/setter on another structure (with different
+    layout; so with different type)
+  - guarantees of full initialization of structures (when it's needed)
+  - can dump structures to human-readable strings
 
   Cons:
-- ocaml-cstruct is easier to add in a project (compare ocaml-cstruct docs
-  with section "How to use" below)
-- ocaml-cstruct uses Camlp4, so it allows one to write cstruct-definitions
-  directly in the code
-- ocaml-cstruct-codegen is written in a very direct, one might even say
-  cynical, way
+  - ocaml-cstruct is easier to add in a project (compare ocaml-cstruct docs
+    with section "How to use" below)
+  - ocaml-cstruct uses Camlp4, so it allows one to write cstruct-definitions
+    directly in the code
+  - ocaml-cstruct-codegen is written in a very direct, one might even say
+    cynical, way
 
 
-  What would this library give you:
+
+        What would this library give you:
 
   For the structure called "mystruct" with a signle field called "a" 
- this library would generates module Mystruct with abstract type t and
-  values:
+this library would generates module Mystruct with abstract type t and
+values:
 
-- val sizeof : int -- get size of structure in octets
-- val get_a : t -> <typeof a> -- get field "a"
-- val set_a : t -> <typeof a> -> unit -- set field "a"
-- val of_bigarray : bigarray -> t -- create Mystruct.t on top of bigarray
-- val bigarray_of : t -> bigarray -- get bigarray of Mystruct.t
-- val create : unit -> t -- create uninitialized Mystruct.t
-- val make : a:<typeof a> -> t -- create Mystruct.t passing initial field
-  values as labelled arguments (so user has guarentees that all fields are
-  initialized)
-- val dump : t -> string -- convert t to human-readable string like "{ a=123 }"
+  - val sizeof : int -- get size of structure in octets
+  - val get_a : t -> <typeof a> -- get field "a"
+  - val set_a : t -> <typeof a> -> unit -- set field "a"
+  - val of_bigarray : bigarray -> t -- create Mystruct.t on top of bigarray
+  - val bigarray_of : t -> bigarray -- get bigarray of Mystruct.t
+  - val create : unit -> t -- create uninitialized Mystruct.t
+  - val make : a:<typeof a> -> t -- create Mystruct.t passing initial field
+    values as labelled arguments (so user has guarentees that all fields are
+    initialized)
+  - val dump : t -> string -- convert t to human-readable string like "{ a=4 }"
+
+  When field "a" is enum of type "myenum" with carrying type "i"
+(int/int32/int64), these values are generated instead of "get_a":
+  - val get_a_num : t -> i -- get field value as a number
+  - val get_a_exn : t -> Myenum.t -- get field value as Myenum.t, throwing
+    exception Enum ("myenum", "badvalue") when field contains value not
+    present in "myenum" definition.
+  - val get_a_res : t -> [ `Ok of Myenum.t | `Error of i ] -- same as
+    [get_a_exn] but returns "badvalue" with [`Error] constructor in numerical
+    form.
 
   This, of course, scales up for multiple fields.
 
 
-  How to use:
 
-Install ocaml-cstruct-codegen.
+        How to define C-like structures and enums:
 
-Add to _oasis:
+
+  First -- open module:
+
+    open Cstruct_codegen
+
+  Then -- enums:
+
+    let myenum = let open Enum in
+      enum "myenum" uint8_t
+      [ elt "A"
+      ; elt "B" ~v:3
+      ; elt "C"
+      ]
+
+  "myenum" gives name to generated module with this enumerated type.
+Here "Myenum.t" will be generated, where type t = A | B | C.
+  uint8_t sets width of fields with type myenum and sets carrying type
+(here -- int).
+  Numeric values of enum elements start from 0 (0l, 0L) unless overriden with
+optional argument "~v" (see "B" definition).  Numeric values increase by 1
+for each next element.  So, here A = 0 (start from 0), B = 3 (explicitely
+specified with ~v:3), C = 4 (not specified, so "previous value + 1").
+This behaviour matches C enum definitions.
+
+  Then -- structures:
+
+    let () = cstruct "mystruct"
+      [ uint8_t "ui8"
+      ; int64_t "si64"
+      ; myenum  "en"
+      ]
+
+  Here "mystruct" is defined, module Mystruct is generated.
+Fields can have either numeric or enum type.
+
+  At last, run code generation:
+
+    let () = codegen "src/mycstructs.ml"
+
+
+
+
+        How to use this library in your project:
+
+
+  Install ocaml-cstruct-codegen.
+
+  Add to _oasis:
 
     PreBuildCommand: sh ./gen_cstructs.sh
 
-Add to _oasis / BuildDepends:
+  Add to _oasis / BuildDepends:
 
     cstruct_codegen, extunix
 
 (since generated code uses extunix library to access bigarray "fields".)
 
-Add to _tags:
+  Add to _tags:
 
     <src/gen_cstructs.*> : pkg_cstruct_codegen
 
-Create ./gen_cstructs.sh:
+  Create ./gen_cstructs.sh:
 
     #! /bin/sh
     ocamlbuild src/gen_cstructs.byte && ./gen_cstructs.byte
 
-In src/gen_cstructs.ml:
+  Write definitions in src/gen_cstructs.ml:
 
     open Cstruct_codegen
     [.. your structure definitions ..]
-    let () = codegen "src/cstructs.ml" [struct1; struct2; ...]
+    let () = codegen "src/cstructs.ml"
 
-Then use "src/cstructs.ml".  Something like:
+  See section "How to define C-like structures and enums" for details.
+
+  Then use "src/cstructs.ml".  Something like:
 
     open Cstructs
     let my1 = Mystruct.make ~a:12 in print_string (Mystruct.dump my1)
 
 
-  People:
 
-- Dmitry Grebeniuk <gdsfh1@gmail.com> -- code
-- Dmitry Astapov <dastapov@gmail.com> -- documentation corrections
+        People:
 
+  - Dmitry Grebeniuk <gdsfh1@gmail.com> -- code
+  - Dmitry Astapov <dastapov@gmail.com> -- documentation corrections
 
-  License:
 
-LGPL-2.1 with OCaml linking exception
+        License:
+
+  LGPL-2.1 with OCaml linking exception
 # Executable test1
 # OASIS_STOP
 
-<lib/*.ml{,i}> | <test/*.ml{,i}> : camlp4r, warn_A, debug
+<**/*.ml{,i}> : warn_A, debug
+<lib/*.ml{,i}> : camlp4r
 <test/*> : use_cstruct_codegen

File lib/cstruct_codegen.ml

-type ftype =
+type ftype_int =
   { getter : string
   ; setter : string
   ; sz : int
   }
 ;
 
+type ftype_enum =
+  { enum_repr : ftype_int
+  ; enum_name : string
+  ; enum_elts : list (string * string)  (* like ("Myenum", "123L") *)
+  }
+;
+
+type ftype =
+  [ Fint of ftype_int
+  | Fenum of ftype_enum
+  ]
+;
+
+
+value enum_module fe = String.capitalize fe.enum_name
+;
+
+value enum_ocamltype fe = (enum_module fe) ^ ".t"
+;
+
+value ocamltype ftype =
+  match ftype with
+  [ Fint fi -> fi.ocamltype
+  | Fenum fe -> enum_ocamltype fe
+  ]
+;
+
+value printer ftype =
+  match ftype with
+  [ Fint fi -> fi.printer
+  | Fenum fe -> (enum_module fe) ^ ".to_string"
+  ]
+;
+
+(*
+value field_of_num fld =
+  match fld.ftype with
+  [ Fint _ -> fld.fname
+  | Fenum fe -> fe.enum_name ^ "_of_num"
+  ]
+;
+
+value num_of_field fld =
+  match fld.ftype with
+  [ Fint _ -> fld.fname
+  | Fenum fe -> "num_of_" ^ fe.enum_name
+  ]
+;
+*)
+
+
 type cfielddef = { fname : string ; ftype : ftype }
 ;
 
 type cstructdef = (string * list cfielddef)
 ;
 
-value cstruct name fields = (name, fields)
+value cstructs = Queue.create ()
+;
+
+value cstruct name fields = Queue.push (name, fields) cstructs
 ;
 
 value accessors_module = "ExtUnix.Specific.BA.LittleEndian"
 
 value printers =
   [ ("int", "string_of_int")
+  ; ("int32", "Int32.to_string")
   ; ("int64", "Int64.to_string")
   ]
 ;
 
 value fld sz fn mlty =
-  let fty =
+  let fty = Fint
     { getter = accessors_module ^ ".unsafe_get_" ^ fn
     ; setter = accessors_module ^ ".unsafe_set_" ^ fn
     ; sz = sz
   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"
 ;
 
 
 (************************************************************)
 
+
+module Enum
+ =
+  struct
+
+    type enum_type 'a =
+      { et_ftype_int : ftype_int
+      ; et_to_literal : 'a -> string
+      ; et_first_val : 'a
+      ; et_next_val : 'a -> 'a
+      }
+    ;
+
+    value et_int fi =
+      { et_ftype_int = fi
+      ; et_to_literal = string_of_int
+      ; et_first_val = 0
+      ; et_next_val = succ
+      }
+    ;
+
+    value et_int32 fi =
+      { et_ftype_int = fi
+      ; et_to_literal = fun x -> (Int32.to_string x) ^ "l"
+      ; et_first_val = 0l
+      ; et_next_val = Int32.add 1l
+      }
+    ;
+
+    value et_int64 fi =
+      { et_ftype_int = fi
+      ; et_to_literal = fun x -> (Int64.to_string x) ^ "L"
+      ; et_first_val = 0L
+      ; et_next_val = Int64.add 1L
+      }
+    ;
+
+    value of_cfield
+     : (string -> cfielddef) -> (ftype_int -> enum_type 'a) -> enum_type 'a
+     = fun cf et ->
+         match (cf "").ftype with
+         [ Fenum _ -> assert False
+         | Fint fi -> et fi
+         ]
+    ;
+
+    value int8_t   : enum_type int   = of_cfield int8_t   et_int  ;
+    value uint8_t  : enum_type int   = of_cfield uint8_t  et_int  ;
+    value int16_t  : enum_type int   = of_cfield int16_t  et_int  ;
+    value uint16_t : enum_type int   = of_cfield uint16_t et_int  ;
+    value int31_t  : enum_type int   = of_cfield int31_t  et_int  ;
+    value int32_t  : enum_type int32 = of_cfield int32_t  et_int32;
+    value int64_t  : enum_type int64 = of_cfield int64_t  et_int64;
+
+
+
+    type enum_elt 'a =
+      { ee_name : string
+      ; ee_opt_val : option 'a
+      }
+    ;
+
+    value elt ?v name = { ee_name = String.capitalize name ; ee_opt_val = v }
+    ;
+
+    value enum
+      name (enumtype : enum_type 'a) (elts : list (enum_elt 'a))
+     : string -> cfielddef
+     =
+      let ftype = Fenum
+        { enum_repr = enumtype.et_ftype_int
+        ; enum_name = String.uncapitalize name
+        ; enum_elts =
+            let cur = ref enumtype.et_first_val in
+            List.map
+              (fun elt ->
+                 let v =
+                   match elt.ee_opt_val with
+                   [ Some v ->
+                       ( cur.val := enumtype.et_next_val v
+                       ; v
+                       )
+                   | None ->
+                       let c = cur.val in
+                       let () = cur.val := enumtype.et_next_val cur.val in
+                       c
+                   ]
+                 in
+                 (String.capitalize elt.ee_name, enumtype.et_to_literal v)
+              )
+              elts
+        }
+      in
+        fun fieldname -> { fname = fieldname ; ftype = ftype }
+    ;
+
+  end
+;
+
+
+(************************************************************)
+
 open Printf
 ;
 
   ; 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
-      )
+
+  ; let for_field { fname = fname ; ftype = ftype_gen } =
+      let gen_get_set ~ftype ~fname =
+        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
+      match ftype_gen with
+      [ Fint ftype ->
+          gen_get_set ~ftype ~fname
+      | Fenum fe ->
+          ( gen_get_set ~ftype:fe.enum_repr ~fname:(fname ^ "_num")
+
+          ; sig_ "val get_%s_exn : t -> %s"
+              fname (enum_ocamltype fe)
+          ; str_ "let get_%s_exn t = %s.of_num_exn (get_%s_num t)"
+              fname (enum_module fe) fname
+
+          ; sig_ "val get_%s_res : t -> [ `Ok of %s | `Error of %s ]"
+              fname (enum_ocamltype fe) fe.enum_repr.ocamltype
+          ; str_ "let get_%s_res t = %s.of_num_res (get_%s_num t)"
+              fname (enum_module fe) fname
+
+          ; sig_ "val set_%s : t -> %s -> unit"
+              fname (enum_ocamltype fe)
+          ; str_ "let set_%s t v = set_%s_num t (%s.num_of v)"
+              fname fname (enum_module fe)
+          )
+      ]
     in
       List.iter for_field csfields
 
                   (String.capitalize csname)
   ; str_ "  else t"
 
+  ; str_ ""
   ; str_ "let create () = %s sizeof" ba_create
 
   ; sig_ ""
       (String.concat ""
          (List.map
             (fun fld ->
-               fld.fname ^ ":" ^ fld.ftype.ocamltype ^ " -> "
+               fld.fname ^ ":" ^ (ocamltype fld.ftype) ^ " -> "
             )
             csfields
          )
 
   ; sig_ ""
   ; sig_ "(* dumps a value of type [t] to string, result looks like"
-  ; sig_ "   \"{ a=1 ; b=3456 }\" *)"
+  ; sig_ "   \"{ a=1 ; b=3456 ; c=Myenumelement }\" *)"
   ; sig_ "val dump : t -> string"
   ; str_ ""
   ; str_ "let dump t ="
      (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
+        ; str_ "    Buffer.add_string b (%s);"
+            (match f.ftype with
+             [ Fint _ ->
+                 Printf.sprintf "%s (get_%s t)" (printer f.ftype) f.fname
+             | Fenum fe ->
+                 Printf.sprintf
+                   "try %s.to_string (get_%s_exn t) with Enum (_, v) -> v"
+                   (enum_module fe) f.fname
+             ]
+            )
         )
      )
      csfields
   output_string outch (string_of_cstructdef cs)
 ;
 
+value enum_exn_written = ref False
+;
+value write_enum_exn outch =
+  if enum_exn_written.val
+  then ()
+  else
+    ( output_string outch "\
+(* exception [Enum (\"myenum\", \"badvalue\")] is raised when \"badvalue\"\n\
+\   is not convertible to value enum type \"myenum\".\n\
+\   \"badvalue\" is a string to cover cases \"123\", \"123l\" and \"123L\".\n\
+\ *)\n\
+exception Enum of (string * string)\n\n"
+    ; enum_exn_written.val := True
+    )
+;
 
-value codegen filename cstructs =
+value codegen_enum outch fe =
+  let () = write_enum_exn outch in
+  let str_ fmt = Printf.ksprintf
+    (fun s -> output_string outch
+       ((if s = "" then "" else "    " ^ s) ^ "\n")
+    ) fmt
+  in
+  ( output_string outch ("module " ^ (enum_module fe) ^ "\n\
+\ =\n\
+\  struct\n\n")
+
+  ; str_ "type t ="
+  ; List.iter
+      (fun (elt_name, _elt_lit) ->
+         str_ "  | %s" elt_name
+      )
+      fe.enum_elts
+  ; str_ ""
+
+  ; str_ "let of_num_exn = function"
+  ; List.iter
+      (fun (elt_name, elt_lit) ->
+         str_ "  | %s -> %s"
+           elt_lit elt_name
+      )
+      fe.enum_elts
+  ; str_ "  | v -> raise (Enum (%S, %s v))"
+      fe.enum_name fe.enum_repr.printer
+  ; str_ ""
+
+  ; List.iter
+      (fun (elt_name, _elt_lit) ->
+         str_ "let ok_%s = `Ok %s"
+           elt_name elt_name
+      )
+      fe.enum_elts
+  ; str_ ""
+
+  ; str_ "let of_num_res = function"
+  ; List.iter
+      (fun (elt_name, elt_lit) ->
+         str_ "  | %s -> ok_%s"
+           elt_lit elt_name
+      )
+      fe.enum_elts
+  ; str_ "  | v -> `Error v"
+  ; str_ ""
+
+  ; str_ "let num_of = function"
+  ; List.iter
+      (fun (elt_name, elt_lit) ->
+         str_ "  | %s -> %s"
+           elt_name elt_lit
+      )
+      fe.enum_elts
+  ; str_ ""
+
+  ; str_ "let to_string = function"
+  ; List.iter
+      (fun (elt_name, _elt_lit) ->
+         str_ "  | %s -> %S"
+           elt_name elt_name
+      )
+      fe.enum_elts
+  ; str_ ""
+
+  ; output_string outch "\
+\  end\n\n"
+  )
+;
+
+
+value codegen_enums outch =
+  let generated = Hashtbl.create 7 in
+  Queue.iter
+    (fun (_csname, csfields) ->
+       List.iter
+         (fun fld ->
+            match fld.ftype with
+            [ Fint _ -> ()
+            | Fenum fe ->
+                if not (Hashtbl.mem generated fe.enum_name)
+                then
+                  ( codegen_enum outch fe
+                  ; Hashtbl.add generated fe.enum_name ()
+                  )
+                else
+                  ()
+            ]
+         )
+         csfields
+    )
+    cstructs
+;
+
+
+value codegen filename =
   let outch = open_out filename in
-  let () = List.iter (codegen_cstruct outch) cstructs in
+  let () = codegen_enums outch in
+  let () = Queue.iter (codegen_cstruct outch) cstructs in
   close_out outch
 ;

File lib/cstruct_codegen.mli

-(* abstract types: *)
+(* field definition: *)
 
 type cfielddef;
-type cstructdef;
 
 (* how to define structure: *)
 
-value cstruct : string -> list cfielddef -> cstructdef;
+value cstruct : string -> list cfielddef -> unit;
 
 (* how to define structure's fields: *)
 
+(* these are represented as [int]: *)
 value int8_t   : string -> cfielddef;
 value uint8_t  : string -> cfielddef;
 value int16_t  : string -> cfielddef;
 value uint16_t : string -> cfielddef;
+value int31_t  : string -> cfielddef;
+
+(* .. as [int32]: *)
+value int32_t  : string -> cfielddef;
+
+(* .. as [int64]: *)
 value int64_t  : string -> cfielddef;
 
-(* how to write an .ml-file with generated code: *)
 
-value codegen : string -> list cstructdef -> unit;
+(* how to define enumeration: *)
+
+module Enum
+ :
+  sig
+    type enum_type 'a;
+    value uint8_t : enum_type int;
+
+    type enum_elt 'a;
+    value elt : ?v : 'a -> string -> enum_elt 'a;
+
+    value enum : string -> enum_type 'a -> list (enum_elt 'a) ->
+                 (string -> cfielddef)
+    ;
+  end
+;
+
+(* how to write an .ml-file with generated code:
+   let () = codegen "filename"
+ *)
+
+value codegen : string -> unit;

File test/test1.ml

-open Cstruct_codegen;
+open Cstruct_codegen
 
-value example = cstruct "mystruct"
+let myenum = let open Enum in
+  enum "myenum" uint8_t
+  [ elt "A"
+  ; elt "B" ~v:3
+  ; elt "C"
+  ]
+
+let () = cstruct "mystruct"
   [ uint8_t  "ui8"
   ; int64_t "si64"
+  ; myenum  "en"
   ]
-;
 
-value () = codegen "/tmp/qwq.ml" [example]
-;
+let () = codegen "/tmp/qwq.ml"
+