From c510c154e04dec4e3a7eab85af674d61dc31b68f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 28 Feb 2014 21:29:55 +0100 Subject: [PATCH] added S-expressions to Conv --- conv.ml | 116 ++++++++++++++++++++++++++++++++++++++++++++++--------- conv.mli | 44 ++++++++++++++++++--- 2 files changed, 137 insertions(+), 23 deletions(-) diff --git a/conv.ml b/conv.ml index 68ba0648..8b6a5984 100644 --- a/conv.ml +++ b/conv.ml @@ -28,8 +28,6 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. exception ConversionFailure of string -let (@@@) a b = a b - (* error-raising function *) let __error msg = let b = Buffer.create 15 in @@ -89,8 +87,7 @@ module Sink = struct let array_ sink = map Array.of_list (list_ sink) - let (-->) a b = a, b - let (|:|) (name,sink) cont = RecordField (name,sink,cont) + let field name sink cont = RecordField (name, sink, cont) let yield_record r = RecordStop r let record r = Record r let record_fix f = @@ -136,6 +133,31 @@ module Sink = struct | "none" -> yield None | _ -> __error "unexpected variant %s" name) + (** What is expected by the sink? *) + type expected = + | ExpectInt + | ExpectBool + | ExpectUnit + | ExpectFloat + | ExpectString + | ExpectRecord + | ExpectTuple + | ExpectList + | ExpectSum + + let rec expected : 'a. 'a t -> expected = function + | Unit _ -> ExpectUnit + | Bool _ -> ExpectBool + | Int _ -> ExpectInt + | Float _ -> ExpectFloat + | String _ -> ExpectString + | Record _ -> ExpectRecord + | Tuple _ -> ExpectTuple + | Sum _ -> ExpectSum + | List _ -> ExpectList + | (Fix f) as sink -> expected (f sink) + | Map (sink', _) -> expected sink' + (** Universal sink, such as a serialization format *) class type ['a] universal = object method unit_ : 'a @@ -187,7 +209,7 @@ module Source = struct let map f src = Map (src, f) let array_ src = map Array.to_list (list_ src) - let record_field name get src' cont = + let field name get src' cont = RecordField (name,get,src',cont) let record_stop = RecordStop let record r = Record r @@ -273,6 +295,14 @@ module Source = struct begin try f (int_of_string s) with Invalid_argument _ -> __error "get String, but expected Int" end + | Sink.Bool f -> + begin try f (bool_of_string s) + with Invalid_argument _ -> __error "get String, but expected Bool" + end + | Sink.Float f -> + begin try f (float_of_string s) + with Invalid_argument _ -> __error "get String, but expected Float" + end | Sink.Map (sink', f) -> f (self#string_ sink' s) | Sink.Fix f -> self#string_ (f sink) s | Sink.Sum _ -> self#sum sink s [] @@ -282,6 +312,7 @@ module Source = struct = fun sink l -> match sink with | Sink.List f -> f (fun sink' -> List.map (self#visit sink') l) + | Sink.Tuple _ -> self#tuple sink l | Sink.Map (sink', f) -> f (self#list_ sink' l) | Sink.Fix f -> self#list_ (f sink) l | _ -> __error "get List, but expected %s" (Sink.__expected sink) @@ -393,7 +424,7 @@ module Json = struct ] let source = object(self) - inherit [t] Source.universal as super + inherit [t] Source.universal method visit sink (x:t) = match x with | `Int i -> self#int_ sink i | `Float f -> self#float_ sink f @@ -402,10 +433,8 @@ module Json = struct | `String s -> self#string_ sink s | `List l -> self#list_ sink l | `Assoc ([name, `List l] as fields) -> - begin match sink with - | Sink.Fix f -> self#visit (f sink) x - | Sink.Map (sink',f) -> f (self#visit sink' x) - | Sink.Sum _ -> self#sum sink name l + begin match Sink.expected sink with + | Sink.ExpectSum -> self#sum sink name l | _ -> self#record sink fields end | `Assoc l -> self#record sink l @@ -426,6 +455,51 @@ module Json = struct end end +module Sexp = struct + type t = + | Atom of string + | List of t list + + let source = object(self) + inherit [t] Source.universal + method visit: 'a. 'a Sink.t -> t -> 'a = fun sink x -> + match x, Sink.expected sink with + | Atom s, Sink.ExpectSum -> self#sum sink s [] + | List (Atom name :: l), Sink.ExpectSum -> self#sum sink name l + | List l, Sink.ExpectRecord -> + let l' = List.map (function + | List [Atom name; x] -> name, x + | _ -> __error "get List, but expected Record") l + in self#record sink l' + | Atom s, _ -> self#string_ sink s + | List [], Sink.ExpectUnit -> self#unit_ sink + | List l, _ -> self#list_ sink l + end + + let sink = object + method unit_ = List [] + method bool_ b = Atom (string_of_bool b) + method int_ i = Atom (string_of_int i) + method float_ f = Atom (string_of_float f) + method string_ s = Atom (String.escaped s) + method list_ l = List l + method tuple l = List l + method record l = List (List.map (fun (a,b) -> List [Atom a; b]) l) + method sum name l = match l with + | [] -> Atom name + | _::_ -> List (Atom name::l) + end + + let rec fmt out = function + | Atom s -> Format.pp_print_string out s + | List l -> + Format.pp_print_char out '('; + List.iteri (fun i s -> + if i > 0 then Format.pp_print_char out ' '; + fmt out s) l; + Format.pp_print_char out ')' +end + (* test for records *) type point = { @@ -438,10 +512,10 @@ type point = { let rec point_sink = Sink.(record_fix (fun self -> - "x" --> int_ |:| fun x -> - "y" --> int_ |:| fun y -> - "color" --> string_ |:| fun color -> - "prev" --> (opt self) |:| fun prev -> + field "x" int_ @@ fun x -> + field "y" int_ @@ fun y -> + field "color" string_ @@ fun color -> + field "prev" (opt self) @@ fun prev -> yield_record {x;y;color;prev} )) @@ -449,10 +523,10 @@ let rec point_sink = let point_source : point Source.t = Source.(record_fix (fun self -> - record_field "x" (fun p -> p.x) int_ @@@ - record_field "y" (fun p -> p.y) int_ @@@ - record_field "color" (fun p -> p.color) string_ @@@ - record_field "prev" (fun p -> p.prev) (opt self) @@@ + field "x" (fun p -> p.x) int_ @@ + field "y" (fun p -> p.y) int_ @@ + field "color" (fun p -> p.color) string_ @@ + field "prev" (fun p -> p.prev) (opt self) @@ record_stop )) @@ -464,3 +538,9 @@ let p2 = into point_source Json.sink p let p3 = from Json.source point_sink p2 let p4 = into point_source Json.sink p3 + +let p2_sexp = into point_source Sexp.sink p + +let p3_sexp = from Sexp.source point_sink p2_sexp + +let p4_sexp = into point_source Sexp.sink p3_sexp diff --git a/conv.mli b/conv.mli index 1b064f45..8f333050 100644 --- a/conv.mli +++ b/conv.mli @@ -28,8 +28,6 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. exception ConversionFailure of string -val (@@@) : ('a -> 'b) -> 'a -> 'b - (** {6 Sinks} A sink is used to traverse values of some type 'a *) module Sink : sig @@ -66,8 +64,7 @@ module Sink : sig val map : ('a -> 'b) -> 'a t -> 'b t val array_ : 'a t -> 'a array t - val (-->) : 'a -> 'b -> 'a * 'b - val (|:|) : (string * 'a t) -> ('a -> 'r record_sink) -> 'r record_sink + val field : string -> 'a t -> ('a -> 'r record_sink) -> 'r record_sink val yield_record : 'r -> 'r record_sink val record : 'r record_sink -> 'r t val record_fix : ('r t -> 'r record_sink) -> 'r t @@ -86,6 +83,22 @@ module Sink : sig val opt : 'a t -> 'a option t + (** What is expected by the sink? *) + type expected = + | ExpectInt + | ExpectBool + | ExpectUnit + | ExpectFloat + | ExpectString + | ExpectRecord + | ExpectTuple + | ExpectList + | ExpectSum + + val expected : _ t -> expected + (** To be used by sources that have ambiguities to know what is expected. + maps and fixpoints are unrolled. *) + (** Universal sink, such as a serialization format *) class type ['a] universal = object method unit_ : 'a @@ -139,7 +152,7 @@ module Source : sig val map : ('b -> 'a) -> 'a t -> 'b t val array_ : 'a t -> 'a array t - val record_field : string -> ('r -> 'a) -> 'a t -> 'r record_src -> 'r record_src + val field : string -> ('r -> 'a) -> 'a t -> 'r record_src -> 'r record_src val record_stop : 'r record_src val record : 'r record_src -> 'r t val record_fix : ('r t -> 'r record_src) -> 'r t @@ -204,5 +217,26 @@ module Json : sig val sink : t Sink.universal end +module Sexp : sig + type t = + | Atom of string + | List of t list + + val source : t Source.universal + val sink : t Sink.universal + val fmt : Format.formatter -> t -> unit (* for debug *) +end + +type point = { + x:int; + y:int; + color:string; + prev : point option; (* previous position, say *) +} + +val p : point val p2 : Json.t val p4 : Json.t + +val p2_sexp : Sexp.t +val p4_sexp : Sexp.t