fixpoint operators for Conv

conv.ml

@@ -28,6 +28,8 @@ 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
@@ -50,6 +52,7 @@ module Sink = struct
     | Tuple : 'a tuple_sink -> 'a t
     | Sum : (string -> ('b t -> 'b) -> 'a) -> 'a t
     | Map : 'a t * ('a -> 'b) -> 'b t
+    | Fix : ('a t -> 'a t) -> 'a t
 
   and 'r record_sink =
     | RecordField : string * 'a t * ('a -> 'r record_sink) -> 'r record_sink
@@ -73,6 +76,7 @@ module Sink = struct
     | Tuple _ -> "tuple"
     | Sum _ -> "sum"
     | Map (sink', _) -> __expected sink'
+    | (Fix f) as sink -> __expected (f sink)
 
   let __id x = x
 
@@ -92,6 +96,8 @@ module Sink = struct
   let (|:|) (name,sink) cont = RecordField (name,sink,cont)
   let yield_record r = RecordStop r
   let record r = Record r
+  let record_fix f =
+    Fix (fun r -> Record (f r))
 
   let (|+|) sink cont = TupleField (sink, cont)
   let yield_tuple t = TupleStop t
@@ -122,6 +128,9 @@ module Sink = struct
     )
 
   let sum f = Sum f
+  let sum_fix f =
+    Fix (fun s -> Sum (f s))
+
   let opt sink = sum (fun name cont ->
       match name with
       | "some" -> Some (cont sink)
@@ -155,6 +164,7 @@ module Source = struct
     | Tuple : 'a tuple_src -> 'a t
     | Sum : ('a -> string * sum_src) -> 'a t
     | Map : 'a t * ('b -> 'a) -> 'b t
+    | Fix : ('a t -> 'a t) -> 'a t
 
   and 'r record_src =
     | RecordField : string * ('r -> 'a) * 'a t * 'r record_src -> 'r record_src
@@ -182,7 +192,8 @@ module Source = struct
     RecordField (name,get,src',cont)
   let record_stop = RecordStop
   let record r = Record r
-  let (@@@) a b = a b
+  let record_fix f =
+    Fix (fun r -> Record (f r))
 
   let tuple_field src get cont = TupleField (src,get,cont)
   let tuple_stop = TupleStop
@@ -209,6 +220,8 @@ module Source = struct
   let sum_nil = SumNil
   let sum_cons src' x tl = SumCons (src', x, tl)
   let sum f = Sum f
+  let sum_fix f =
+    Fix (fun s -> Sum (f s))
 
   let opt src = sum (function
       | Some x -> "some", sum_cons src x sum_nil
@@ -226,6 +239,7 @@ module Source = struct
       | Sink.Unit u -> u
       | Sink.Int f -> f 0
       | Sink.Map (sink', f) -> f (self#unit_ sink')
+      | Sink.Fix f -> self#unit_ (f sink)
       | _ -> __error "get Unit, but expected %s" (Sink.__expected sink)
 
     method private bool_ : 'b. 'b Sink.t -> bool -> 'b
@@ -234,6 +248,7 @@ module Source = struct
       | Sink.Int f -> f (if b then 1 else 0)
       | Sink.String f -> f (string_of_bool b)
       | Sink.Map (sink', f) -> f (self#bool_ sink' b)
+      | Sink.Fix f -> self#bool_ (f sink) b
       | _ -> __error "get Bool, but expected %s" (Sink.__expected sink)
 
     method private float_ : 'b. 'b Sink.t -> float -> 'b
@@ -241,6 +256,7 @@ module Source = struct
       | Sink.Float f -> f x
       | Sink.String f -> f (string_of_float x)
       | Sink.Map (sink', f) -> f (self#float_ sink' x)
+      | Sink.Fix f -> self#float_ (f sink) x
       | _ -> __error "get Float, but expected %s" (Sink.__expected sink)
 
     method private int_ : 'b. 'b Sink.t -> int -> 'b
@@ -248,6 +264,7 @@ module Source = struct
       | Sink.Int f -> f i
       | Sink.String f -> f (string_of_int i)
       | Sink.Map (sink', f) -> f (self#int_ sink' i)
+      | Sink.Fix f -> self#int_ (f sink) i
       | _ -> __error "get Int, but expected %s" (Sink.__expected sink)
 
     method private string_ : 'b. 'b Sink.t -> string -> 'b
@@ -258,6 +275,7 @@ module Source = struct
         with Invalid_argument _ -> __error "get String, but expected Int"
         end
       | Sink.Map (sink', f) -> f (self#string_ sink' s)
+      | Sink.Fix f -> self#string_ (f sink) s
       | _ -> __error "get String, but expected %s" (Sink.__expected sink)
 
     method private list_ : 'b. 'b Sink.t -> 'a list -> 'b
@@ -265,6 +283,7 @@ module Source = struct
       | Sink.List f ->
         f (fun sink' -> List.map (self#visit 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)
 
     method private record : 'b. 'b Sink.t -> (string*'a) list -> 'b
@@ -280,6 +299,7 @@ module Source = struct
               build_record (cont sink_field)
         in build_record r
       | Sink.Map (sink', f) -> f (self#record sink' l)
+      | Sink.Fix f -> self#record (f sink) l
       | _ -> __error "get Record, but expected %s" (Sink.__expected sink)
 
     method private tuple : 'b. 'b Sink.t -> 'a list -> 'b
@@ -298,6 +318,7 @@ module Source = struct
               build_tuple l' (cont y)
         in build_tuple l t_sink
       | Sink.Map (sink', f) -> f (self#tuple sink' l)
+      | Sink.Fix f -> self#tuple (f sink) l
       | _ -> __error "get Tuple, but expected %s" (Sink.__expected sink)
 
     method private sum : 'b. 'b Sink.t -> string -> 'a -> 'b
@@ -305,6 +326,7 @@ module Source = struct
       | Sink.Sum f ->
           f name (fun sink' -> self#visit sink' s)
       | Sink.Map (sink', f) -> f (self#sum sink' name s)
+      | Sink.Fix f -> self#sum (f sink) name s
       | _ -> __error "get Sum(%s), but expected %s" name (Sink.__expected sink)
 
     method virtual visit : 'b. 'b Sink.t -> 'a -> 'b
@@ -348,6 +370,9 @@ let rec into : type a b. a Source.t -> b Sink.universal -> a -> b =
       let name, sum = f x in
       conv_sum name [] sum
   | Source.Map (src', f) -> into src' sink (f x)
+  | Source.Fix f ->
+      let src' = f src in
+      into src' sink x
 
 let from (src:'a Source.universal) (sink:'b Sink.t) (x:'a) : 'b = src#visit sink x
 
@@ -397,26 +422,32 @@ type point = {
   x:int;
   y:int;
   color:string;
+  prev : point option; (* previous position, say *)
 }
 
-let point_sink =
+let rec point_sink =
-  Sink.(record (
+  Sink.(record_fix
+    (fun self ->
       "x" --> int_ |:| fun x ->
       "y" --> int_ |:| fun y ->
       "color" --> string_ |:| fun color ->
-      yield_record {x;y;color}
+      "prev" --> (opt self) |:| fun prev ->
-  ))
+      yield_record {x;y;color;prev}
+    ))
 
 
 let point_source : point Source.t =
-  Source.(record (
+  Source.(record_fix
-    record_field "x" (fun p -> p.x) int_ @@@
+    (fun self ->
-    record_field "y" (fun p -> p.y) int_ @@@
+      record_field "x" (fun p -> p.x) int_ @@@
-    record_field "color" (fun p -> p.color) string_ @@@
+      record_field "y" (fun p -> p.y) int_ @@@
-    record_stop
+      record_field "color" (fun p -> p.color) string_ @@@
-  ))
+      record_field "prev" (fun p -> p.prev) (opt self) @@@
+      record_stop
+    ))
 
-let p = {x=1; y=42; color="yellow"; }
+let p = {x=1; y=42; color="yellow";
+         prev = Some {x=1; y=41; color="red"; prev=None};}
 
 let p2 = into point_source Json.sink p
 (* TODO tests *)

conv.mli

@@ -28,12 +28,14 @@ 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
   (** A specific sink that requires a given shape to produce
-   * a value of type 'a *)
+     a value of type 'a *)
-  type 'a t =
+  type 'a t = private
     | Unit : 'a -> 'a t
     | Bool : (bool -> 'a) -> 'a t
     | Float : (float -> 'a) -> 'a t
@@ -44,6 +46,7 @@ module Sink : sig
     | Tuple : 'a tuple_sink -> 'a t
     | Sum : (string -> ('b t -> 'b) -> 'a) -> 'a t
     | Map : 'a t * ('a -> 'b) -> 'b t
+    | Fix : ('a t -> 'a t) -> 'a t
 
   and 'r record_sink =
     | RecordField : string * 'a t * ('a -> 'r record_sink) -> 'r record_sink
@@ -70,6 +73,7 @@ module Sink : sig
   val (|:|) : (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
 
   val (|+|) : 'a t -> ('a -> 't tuple_sink) -> 't tuple_sink
   val yield_tuple : 't -> 't tuple_sink
@@ -80,6 +84,8 @@ module Sink : sig
   val quad : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t
 
   val sum : (string -> ('b t -> 'b) -> 'a) -> 'a t
+  val sum_fix : ('a t -> string -> ('b t -> 'b) -> 'a) -> 'a t
+
   val opt : 'a t -> 'a option t
 
   (** Universal sink, such as a serialization format *)
@@ -100,7 +106,7 @@ end
 A source is used to build values of some type 'a *)
 module Source : sig
   (** A specific source that follows the shape of the type 'a *)
-  type 'a t =
+  type 'a t = private
     | Unit : unit t
     | Bool : bool t
     | Float : float t
@@ -111,6 +117,7 @@ module Source : sig
     | Tuple : 'a tuple_src -> 'a t
     | Sum : ('a -> string * sum_src) -> 'a t
     | Map : 'a t * ('b -> 'a) -> 'b t
+    | Fix : ('a t -> 'a t) -> 'a t
 
   and 'r record_src =
     | RecordField : string * ('r -> 'a) * 'a t * 'r record_src -> 'r record_src
@@ -131,14 +138,13 @@ module Source : sig
   val string_ : string t
   val list_ : 'a t -> 'a list t
 
-  val (@@@) : ('a -> 'b) -> 'a -> 'b
-
   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 record_stop : 'r record_src
   val record : 'r record_src -> 'r t
+  val record_fix : ('r t -> 'r record_src) -> 'r t
 
   val tuple_field : 'a t -> ('t -> 'a) -> 't tuple_src -> 't tuple_src
   val tuple_stop : 't tuple_src
@@ -151,6 +157,7 @@ module Source : sig
   val sum_nil : sum_src
   val sum_cons : 'a t -> 'a -> sum_src -> sum_src
   val sum : ('a -> string * sum_src) -> 'a t
+  val sum_fix : ('a t -> 'a -> string * sum_src) -> 'a t
 
   val opt : 'a t -> 'a option t
 
@@ -194,3 +201,5 @@ module Json : sig
   val source : t Source.universal
   val sink : t Sink.universal
 end
+
+val p2 : Json.t