1. camlspotter
  2. meta_conv

Commits

camlspotter  committed 634281b Merge

merged with 4.01.0

  • Participants
  • Parent commits d97b001, 1366df4
  • Branches default

Comments (0)

Files changed (13)

File Changes

View file
+1.1.2
+-------------
+
+- Added xml_conv for 
+
 1.1.1
 -------------
 

File OMyMakefile

View file
 OCAMLFLAGS = -g 
 
 #|Warnings not to be printed separted with space
-OCAMLWARNING_IGNORE[] = 4 9
+OCAMLWARNING_IGNORE[] = 4 9 40 42 44 45
 
 #|Warnings treated as non errors
-OCAMLWARNING_NON_ERROR[] = 4 9
+OCAMLWARNING_NON_ERROR[] = 4 9 40 42 44 45
 
 #|If it is false, warnings do not stop the compilation even if they are listed in OCAMLWARNING_NON_ERROR
-#If you are in developing something, turn it ture!
+#If you are in developing something, turn it to true!
 OCAMLWARNING_STOP_AT_ERROR_WARNING=false
 
 #|The maximum warning value.
 # This is the maximum warning ID NOT of the current OCaml compiler,
 #                                BUT of the OCaml compiler used by the author.
-OCAMLWARNING_MAX= 39
+OCAMLWARNING_MAX= 45
 
 #|Function to build warning switches
 OCAMLWARNING_MAKE()=

File json/json.ml

View file
 type t =
   | String of string
-  | Number of float
+  | Number of float (* CR jfuruse: BUG: It cannot carry full int64 value. *)
   | Object of obj
   | Array of t list
   | Bool of bool

File json/json_conv.ml

View file
 
 let json_of_int n       = Number (float n)
 let json_of_int32 n     = Number (Int32.to_float n)
-let json_of_int64 n     = Number (Int64.to_float n)
+let json_of_int64 n     = Number (Int64.to_float n) (* CR jfuruse: BUG: Int64.max_int cannot be mapped to float properly *)
 let json_of_nativeint n = Number (Nativeint.to_float n)
 let json_of_char c      = String (String.make 1 c)
 let json_of_string s    = String s
 let json_of_bool b      = Bool b
 let json_of_lazy_t f v  = f (Lazy.force v)
 let json_of_unit ()     = Null
+(* CR jfuruse: BUG: this makes [None] and [Some (None)] not distinguishable. i.e. t option^n are all mapped to t option *)
 let json_of_option f    = function
   | None -> Null
   | Some v -> f v
 let array_of_json f = 
   Helper.array_of (function Array xs -> Some xs | _ -> None) f
 
+(* CR jfuruse: BUG: Due to the inaccurate encoding of option, Some (Some (Some (Some x))) is encoded then decoded back to Some x *)
 let option_of_json f = Helper.option_of 
   (function Null -> Some None | v -> Some (Some v))
   f

File ocaml/ocaml.ml

View file
         | Unclosed (loc, _, _, _) -> loc
         | Applicative_path loc -> loc
         | Variable_in_scope (loc, _) -> loc
+        | Expecting (loc, _) -> loc
         | Other loc -> loc
         end
     | `Exn _ -> Location.none

File xml/META

View file
+version = "1.1.2"
+description = "xml_conv - type_conv, meta_conv based XML value encoder/decoder"
+requires = "meta_conv,compiler-libs.common"
+archive(byte) = "xml_conv.cma"
+archive(native) = "xml_conv.cmxa"
+
+

File xml/META.in

View file
+version = "@version@"
+description = "xml_conv - type_conv, meta_conv based XML value encoder/decoder"
+requires = "meta_conv,compiler-libs.common"
+archive(byte) = "xml_conv.cma"
+archive(native) = "xml_conv.cmxa"
+
+

File xml/OMakefile

View file
+OCAMLINCLUDES += ../lib
+
+LIBFILES[] =
+   std_xml
+   xml_conv
+
+LIB = xml_conv
+
+MyOCamlLibrary($(LIB), $(LIBFILES))
+
+Subdirs()

File xml/std_xml.ml

View file
+type 'a t = 
+  | PCData of string
+  | Element of (string * ((string * string) list) * ('a list))
+
+let escape_attr_value s =
+  let buf = Buffer.create (String.length s * 2) in
+  String.iteri (fun _ c ->
+    match c with
+    | '"' -> Buffer.add_string buf "\\\""
+    | '\\' -> Buffer.add_string buf "\\\\"
+    | c -> Buffer.add_char buf c) s;
+  Buffer.contents buf
+
+let escape_pcdata s =
+  let len = String.length s in
+  let buf = Buffer.create (len * 2) in
+  (* CR jfuruse: this is far from perfect *)
+  String.iteri (fun i c ->
+    match c with
+    | '>' -> Buffer.add_string buf ">"
+    | '<' -> Buffer.add_string buf "&lt;"
+    | '&' ->
+	if i < len-1 && s.[i+1] = '#' then
+	  Buffer.add_char buf '&'
+	else
+	  Buffer.add_string buf "&amp;"
+    | '\'' -> Buffer.add_string buf "&apos;"
+    | '"' -> Buffer.add_string buf "&quot;"
+    | c -> Buffer.add_char buf c) s;
+  Buffer.contents buf
+
+open Format
+
+let rec list (sep : (unit, formatter, unit) format)  f ppf = function
+  | [] -> ()
+  | [x] -> f ppf x
+  | x::xs -> 
+      fprintf ppf "@[%a@]%t%a" 
+	f x
+	(fun ppf -> fprintf ppf sep)
+	(list sep f) xs
+
+let rec format f ppf = function
+  | PCData s -> Format.pp_print_string ppf @@ escape_pcdata s (* CR jfuruse: consecutive PCData's are simply printed without separators *)
+  | Element (tag, [], []) ->
+      fprintf ppf "@[<0><%s/>@]"
+        tag 
+  | Element (tag, attrs, []) ->
+      fprintf ppf "@[<0><%s @[%a@]/>@]"
+        tag 
+        format_attrs attrs
+  | Element (tag, [], xmls) ->
+      fprintf ppf "@[<2><%s>@,%a@,</%s>@]"
+        tag
+        (list "@," f) xmls
+        tag
+  | Element (tag, attrs, xmls) ->
+      fprintf ppf "@[<2><%s @[%a@]>@,%a@,</%s>@]"
+        tag
+        format_attrs attrs
+        (list "@," f) xmls
+        tag
+and format_attrs ppf = list "@ " (fun ppf (k,v) -> fprintf ppf "%s=\"%s\"" k (escape_attr_value v)) ppf

File xml/std_xml.mli

View file
+type 'a t = 
+  | PCData of string
+  | Element of (string * ((string * string) list) * 'a list)
+
+val format : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit

File xml/tests/OMakefile

View file
+OCAMLWARNING_IGNORE += 24
+OCAMLWARNING_NON_ERROR += 24
+
+%.out.ml: %.ml ../../pa/pa_meta_conv.cma 
+    camlp4o -I $(OCAMLFIND_QUERY type_conv) pa_type_conv.cma ../../pa/pa_meta_conv.cma  -printer Camlp4OCamlPrinter $< > $@
+
+%.out.mli: %.mli ../../pa/pa_meta_conv.cma 
+    camlp4o -I $(OCAMLFIND_QUERY type_conv) pa_type_conv.cma ../../pa/pa_meta_conv.cma  -printer Camlp4OCamlPrinter $< > $@
+
+OCAMLPACKS +=
+
+test.out: test.out.ml ../std_xml.cmo ../../lib/meta_conv.cmo ../../lib/meta_conv.cmi ../xml_conv.cma 
+    $(OCamlC) -I .. -I ../../lib ../../lib/meta_conv.cmo ../xml_conv.cma test.out.ml -o $@
+
+%.out.auto.mli: %.out.ml ../std_xml.cmi ../xml_conv.cmi
+    $(OCamlC) -c -i -I .. -I ../../lib  test.out.ml > $@
+
+.DEFAULT: test.out.ml test.out test.out.auto.mli
+
+AutoClean()

File xml/tests/test.ml

View file
+open Meta_conv.Open
+module Xml = struct
+  type t = { x : t Std_xml.t }
+  let element t attrs xs = { x = Std_xml.Element (t, attrs, xs) }
+  let pcdata s = { x = Std_xml.PCData s }
+  let deconstr {x=t} = t
+  let rec format ppf {x=t} = Std_xml.format format ppf t
+end
+module Xml_conv = Xml_conv.Make(Xml)
+open Xml_conv
+
+module Test1 = struct
+  type t = Foo | Bar of int * string with conv(xml)
+
+  let () =
+    let x = Bar (0, "hello") in
+    assert (t_of_xml (xml_of_t x) = `Ok x)
+end
+
+module Test2 = struct
+  type t = { foo : int; bar : float option } with conv(xml)
+
+  let () =
+    let x = { foo = 3; bar = Some 1.2 } in
+    assert (t_of_xml (xml_of_t x) = `Ok x)
+end
+
+module Test3 = struct
+  open Test2
+  type t = Test2.t with conv(xml)
+
+  let () =
+    let x = { foo = 3; bar = Some 1.2 } in
+    assert (t_of_xml (xml_of_t x) = `Ok x)
+end
+
+module Test4 = struct
+  type t = Foo (:"foo":) | Bar (:"bar":) of int * string with conv(xml)
+
+  let () =
+    let x = Bar (0, "hello") in
+    assert (t_of_xml (xml_of_t x) = `Ok x)
+end
+
+module Test5 = struct
+  type t (: Ignore_unknown_fields :) = { x : int; y : float } with conv (xml)
+  type t' = { x' as "x" : int; y' as "y" : float; z' as "z" : unit  } with conv (xml)
+
+  let () =
+    let r' = { x' = 1; y' = 1.0; z' = () }  in
+    assert (t_of_xml (xml_of_t' r') = `Ok { x = 1; y = 1.0 })
+end
+
+let xml_format_with f = fun ppf v -> Xml.format ppf (f v)
+  
+module Test6 = struct
+  type t = { x : int; y : float; rest : Xml.t mc_leftovers; } with conv (xml)
+  type t' = { x' as "x" : int; y' as "y" : float; z' as "z" : unit  } with conv (xml)
+
+  let format_t' = xml_format_with xml_of_t'
+
+  let () =
+    let r' = { x' = 1; y' = 1.0; z' = () }  in
+    assert (t_of_xml (xml_of_t' r') = `Ok { x = 1; y = 1.0; rest = [ "z", Xml.element "unit" [] [] ] });
+    assert (xml_of_t (match t_of_xml (xml_of_t' r') with `Ok v -> v | _ -> assert false) = xml_of_t' r');
+    Format.eprintf "r' = %a@." format_t' r'
+end
+
+(*
+module Test7 = struct
+  type t = { x : int; y : float; rest : Xml.t mc_leftovers; } with conv (xml)
+  type t' = { x' as "x" : int; y' as "y" : float; z' as "z" : unit  } with conv (xml)
+
+  let format_t = xml_format_with xml_of_t
+
+  let () =
+    let r' = { x' = 1; y' = 1.0; z' = () }  in
+    let format_sprintf fmt = Format.(
+      let buf = Buffer.create 100 in
+      let ppf = formatter_of_buffer buf in
+      kfprintf (fun ppf -> pp_print_flush ppf (); Buffer.contents buf) ppf fmt
+    ) in
+    let s = format_sprintf "%a" (fun x -> Xml.format x) (xml_of_t' r') in
+    prerr_endline s;
+    let o = match Xml.Parser.from_string s with [x] -> x | _ -> assert false in
+    Format.eprintf "parse done: %a@." (fun x -> Xml.format x) o;
+    try
+      let r = t_of_xml_exn o in
+      Format.eprintf "r = %a@." format_t r
+    with
+    | Xml_conv.Error e ->
+        Xml_conv.format_full_error Format.err_formatter e
+end
+*)
+
+module Test8 = struct
+  type t = < x : int; y : string > with conv(xml)
+end
+

File xml/xml_conv.ml

View file
+open Printf
+open Std_xml
+
+(** The names of type and modules
+
+    If you want to auto generate of conversion functions [conv(xxx)] 
+    of your target data type,
+
+    * Your target data must have a name [Xxx.t] (here [Json.t]).
+      (You can put it in another module [Aaa.Bbb.Xxx.t], but the data type must
+       be accessible by [Xxx.t]: you need to [open Aaa.Bbb].
+
+    * You must write a convesion module named [Xxx_conv] (here [Json_conv], this file.),
+      and make it accessible as [Xxx_conv]. (Same again, you can put the module inside
+      another module, but then, you need [open]. 
+
+*)
+
+(** Basic requirement: [include Meta_conv.Coder.Make(...)]
+
+   You must define a module with
+
+   * The target type [target], here [Json.t]
+   * [format], a printer for [target], useful for debugging
+   * And the basic constructor and deconstructor modules of [target], 
+     [Constr] and [Deconstr] respectively.
+
+   and apply [Meta_conv.Coder.Make] to it, and include the result.
+*)
+
+module Make(Xml : sig
+  type t
+  val format : Format.formatter -> t -> unit
+  val pcdata : string -> t
+  val element : string -> (string * string) list -> t list -> t
+  val deconstr : t -> t Std_xml.t
+end) = struct
+
+  include Meta_conv.Coder.Make(struct 
+    open Xml
+  
+    type target = Xml.t  (** This is the target type! *)
+  
+    (** [format]: printer of [target] *)
+    let format = Xml.format
+  
+    (** [Constr]: Constructors.
+  
+        This module implements how to construct a [target] value from other [target] values.
+        It must have: 
+  
+          val tuple        : target list -> target
+          val variant      : string -> target list -> target
+          val poly_variant : string -> target list -> target
+          val record       : (string * target) list -> target
+          val object_      : (string * target) list -> target
+  
+        It is often the case that you do not really distinguish records and objects,
+        and variants and polymorphic variants. In that case, you can write simply
+        [let poly_variant = variant and object_ = record].
+    *)
+    module Constr = struct
+      let tuple ts = element "elements" [] @@ List.map (fun t -> element "elem" [] [t]) ts
+      let variant _tyname tag = function
+        | [] -> element tag [] []
+        | ts -> element tag [] ts
+      let record _tyname tag_ts  = element "record" [] @@ List.map (fun (tag,t) -> element tag [] [t]) tag_ts
+      let poly_variant = variant (* We use the same construction as variants *)
+      let object_ = record (* We use the same construction as records *)
+    end
+  
+    (** [Deconstr]: Deconstructors.
+  
+        This module implements how to deconstruct a [target] value to sub [target] values.
+        It must have: 
+  
+          val tuple        : target -> target list
+          val variant      : target -> string * target list
+          val poly_variant : target -> string * target list
+          val record       : target -> (string * target) list
+          val object_      : target -> (string * target) list
+  
+        If deconstruction is impossible, the functions can raise exceptions. The exceptions
+        are caught and result into decoding failure errors. For example, if [tuple] takes
+        a target value which is not interpretable as a tuple, it should raise an exception.
+  
+        It is often the case that you do not really distinguish records and objects,
+        and variants and polymorphic variants. In that case, you can write simply
+        [let poly_variant = variant and object_ = record].
+    *)
+    module Deconstr = struct
+    
+      let tuple t = match deconstr t with
+        | Element ("elements", _, es) -> 
+            List.map (fun t -> match deconstr t with
+              | Element ("elem", _, [t]) -> t
+              | _ -> failwith "<elem>x</elem> expected for tuple element") es
+        | _ -> 
+            failwith "<elements> expected for tuple" 
+    
+      let variant _tyname t = match deconstr t with
+        | Element (tag, _, ts) -> tag, ts
+        | _ -> failwith "Element expected for variant"
+    
+      let record _tyname t = match deconstr t with
+        | Element ("record", _, es) ->
+            List.map (fun t -> match deconstr t with
+              | Element (tag, _, [t]) -> tag, t
+              | _ -> failwith "<x>y</x> for some x expected for record field") es
+        | _ -> failwith "<record> expected for record"
+    
+      let poly_variant = variant
+      let object_ = record
+    end
+  
+  end)
+
+  (** Auxiliary: encoders and decoders for primitive types: [xxx_of_<type>] and [<type>_of_xxx] 
+  
+      Conversion functions for derived types which are defined using 
+      [type t = ... with conv(xxx)] are created by [pa_meta_conv] CamlP4 extension,
+      but those for primitive types are not. You need to define them by yourself.
+  
+      Primitive types are types without definitinons. Popular primitive types are:
+      int, int32, int64, nativeint, char, string, float, list, array, bool, lazy_t,
+      unit, option and Hashtbl.t.
+  
+      You should define encoders and decoders for those types in [Xxx_conv] module.
+      You do not need to define en/decoders of all the primitive types, but 
+      of course Meta_conv cannot auto-generate coders of derived types whose definitions
+      depend on primitive types without coders.
+  
+      The names of coders for a primitive type <type> is [xxx_of_<type>] and
+      [<type>_of_xxx]. Here, we are defining things for [conv(json)], so 
+      they are [json_of_<type>] and [<type>_of_json].
+  *)
+  
+  (** Encoders for primitive types *)
+  
+  let xml_of_int n       = Xml.pcdata (string_of_int n)
+  let xml_of_int32 n     = Xml.pcdata (Int32.to_string n)
+  let xml_of_int64 n     = Xml.pcdata (Int64.to_string n)
+  let xml_of_nativeint n = Xml.pcdata (Nativeint.to_string n)
+  let xml_of_char c      = Xml.pcdata (String.make 1 c)
+  let xml_of_string s    = Xml.pcdata s
+  let xml_of_float n     = Xml.pcdata (Printf.sprintf "%.20G" n) (* CR jfuruse: not sure... *)
+  let xml_of_list f xs   = Xml.element "elements" [] @@ List.map f xs
+  let xml_of_array f xs  = Xml.element "elements" [] @@ List.map f (Array.to_list xs)
+  let xml_of_bool = function
+    | true -> Xml.element "true" [] []
+    | false -> Xml.element "false" [] []
+  let xml_of_lazy_t f v  = f (Lazy.force v)
+  let xml_of_unit ()     = Xml.element "unit" [] []
+  let xml_of_option f    = function
+    | None -> Xml.element "none" [] []
+    | Some v -> Xml.element "some" [] [f v]
+    
+  (** Decoders for primitive types 
+  
+      Usually decoders are harder to imlement compared to encoders.
+      There is a module [Helper] available, which is created by the above
+      [Meta_conv.Coder.Make(...)]. [Helper] provides some useful functions
+      for decoders. See the module type [Types.S] to know about [Helper].
+  
+      Note that [<type>_of_xxx] must report the decoding errors using
+      the Result monad (See [Meta_conv.Result]). You should not raise
+      an exception inside a decoder, or, use [result] to wrap a function
+      of type [decoder_exn]. (They are available via the above 
+      [include Meta_conv.Coder.Make(...)]. See [Types.S] for details.)
+  *)
+  
+  let failwithf fmt = kprintf (fun s -> raise (Failure s)) fmt
+
+  let of_deconstr f = Helper.of_deconstr (fun t -> f (Xml.deconstr t))
+
+  let string_of_xml = of_deconstr (function
+    | PCData s -> s
+    | _ -> failwith "string_of_xml: PCData expected")
+  
+  let char_of_xml = of_deconstr (function
+    | PCData s when String.length s = 1 -> s.[0]
+    | _ -> failwith "char_of_xml: a char expected")
+  
+  let int_check name _min _max conv = of_deconstr (function 
+    | PCData n -> conv n
+    | _ -> failwithf "%s_of_xml: PCData expected" name)
+  
+  let int_of_xml =
+    int_check "int" (float min_int) (float max_int) int_of_string
+  
+  let int64_of_xml =
+    let open Int64 in
+    int_check "int64" (to_float min_int) (to_float max_int) Int64.of_string
+        
+  let int32_of_xml =
+    let open Int32 in
+    int_check "int32" (to_float min_int) (to_float max_int) Int32.of_string
+        
+  let nativeint_of_xml = 
+    let open Nativeint in
+    int_check "nativeint" (to_float min_int) (to_float max_int) Nativeint.of_string
+        
+  let float_of_xml = of_deconstr (function
+    | PCData n -> float_of_string n
+    | _ -> failwith "float_of_xml: PCData expected")
+  
+  let bool_of_xml = of_deconstr (function
+    | Element ("true", _, []) -> true
+    | Element ("false", _, []) -> false
+    | _ -> failwith "bool_of_xml: <true/> or <false/> expected")
+  
+  let unit_of_xml = of_deconstr (function
+    | Element ("unit", _, []) -> ()
+    | _ -> failwith "unit_of_xml: <unit/> expected")
+    
+  let list_of_xml f = 
+    Helper.list_of (fun t -> match Xml.deconstr t with
+    | Element ("elements", _, xs) -> 
+        begin try Some (List.map (fun t -> match Xml.deconstr t with Element("elem", _, [x]) -> x | _ -> raise Exit) xs) with _ -> None end
+    | _ -> None) f
+  
+  let array_of_xml f = 
+    Helper.array_of (fun t -> match Xml.deconstr t with
+    | Element ("elements", _, xs) -> 
+        begin try Some (List.map (fun t -> match Xml.deconstr t with Element("elem", _, [x]) -> x | _ -> raise Exit) xs) with _ -> None end
+    | _ -> None) f
+  
+  let option_of_xml f = Helper.option_of (fun t -> match Xml.deconstr t with
+      | Element("none", _, []) -> Some None
+      | Element("some", _, [x]) -> Some (Some x)
+      | _ -> None) f
+  
+  let lazy_t_of_xml d = Helper.lazy_t_of (fun e -> raise (Error e)) d
+  
+  (** Auxiliary: encoders and decoders of Meta_conv special types.
+  
+      Special types such as [mc_lazy_t] and [mc_fields] require their own special
+      en/decoders. If you want to use those special types, you must define those
+      coders.
+   *)
+  
+  let xml_of_mc_lazy_t = Helper.of_mc_lazy_t
+  let mc_lazy_t_of_xml = Helper.mc_lazy_t_of
+  
+  let xml_of_mc_fields enc xs = 
+    Constr.record "mc_fields" (List.map (fun (name, a) -> (name, enc a)) xs)
+  
+  let mc_fields_of_xml dec = 
+    Helper.mc_fields_of (fun t -> match Xml.deconstr t with
+      | Element ("record", _, xs) -> 
+          begin try
+            Some (List.map (fun t -> match Xml.deconstr t with
+              | Element (k, _, [v]) -> k,v
+              | _ -> raise Exit) xs)
+          with
+          | Exit -> None
+          end
+      | _ -> None) dec
+end