From d794b6f726710c957a0d077451654dedad1ba731 Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Sat, 1 Mar 2014 18:53:26 +0100
Subject: [PATCH] more efficient and simple serialization, using function
 combinators instead of a single GADT

---
 conv.ml  | 503 +++++++++++++++++++++++++++----------------------------
 conv.mli | 181 ++++++++++----------
 2 files changed, 339 insertions(+), 345 deletions(-)

diff --git a/conv.ml b/conv.ml
index 7cf15b78..ab72de05 100644
--- a/conv.ml
+++ b/conv.ml
@@ -36,6 +36,139 @@ let __error msg =
     (fun b -> raise (ConversionFailure (Buffer.contents b)))
     b msg
 
+(* function to look up the given name in an association list *)
+let _get_field l name =
+  try List.assoc name l
+  with Not_found ->
+    __error "record field %s not found in source" name
+
+(** Universal sink, such as a serialization format *)
+module UniversalSink = struct
+  type 'a t = {
+    unit_ : 'a;
+    bool_ : bool -> 'a;
+    float_ : float -> 'a;
+    int_ : int -> 'a;
+    string_ : string -> 'a;
+    list_ : 'a list -> 'a;
+    record : (string*'a) list -> 'a;
+    tuple : 'a list -> 'a;
+    sum : string -> 'a list -> 'a;
+  }
+end
+
+module Source = struct
+  module US = UniversalSink
+
+  type 'a t = {
+    convert : 'b. 'b US.t -> 'a -> 'b;
+  }
+
+  type 'r record_src =
+    | RecordField : string * ('r -> 'a) * 'a t * 'r record_src -> 'r record_src
+    | RecordStop : 'r record_src
+
+  type hlist =
+    | HNil : hlist
+    | HCons : 'a t * 'a * hlist -> hlist
+
+  let hnil = HNil
+  let hcons src x tl = HCons(src,x,tl)
+
+  let unit_ = { convert = (fun sink () -> sink.US.unit_); }
+  let bool_ = { convert = (fun sink b -> sink.US.bool_ b); }
+  let float_ = { convert = (fun sink f -> sink.US.float_ f); }
+  let int_ = { convert = (fun sink i -> sink.US.int_ i); }
+  let string_ = { convert = (fun sink s -> sink.US.string_ s); }
+  let list_ e =
+    let convert sink l =
+      let l' = List.map (e.convert sink) l in
+      sink.US.list_ l'
+    in {convert;}
+
+  let map f src =
+    { convert=(fun sink x -> src.convert sink (f x)); }
+  let array_ src = map Array.to_list (list_ src)
+
+  let field name get src' cont =
+    RecordField (name,get,src',cont)
+  let record_stop = RecordStop
+
+  let record (r:'a record_src) =
+    (* fold over record description *)
+    let rec conv_fields
+    : type b. b US.t -> (string*b)list -> 'a record_src -> 'a -> (string*b)list
+    = fun sink acc r x -> match r with
+    | RecordStop -> acc
+    | RecordField (name,get,src',r') ->
+        let acc = (name, src'.convert sink (get x)) :: acc in
+        conv_fields sink acc r' x
+    in
+    let convert sink x = sink.US.record (conv_fields sink [] r x) in
+    { convert; }
+
+  let record_fix f =
+    let rec convert: type b. b US.t -> 'r -> b
+    = fun sink x ->
+        (* evaluate src, and use it to convert x *)
+        (Lazy.force src).convert sink x
+    and src = lazy (record (f {convert})) in
+    Lazy.force src
+
+  (* fold over hlist *)
+  let rec conv_hlist : type b. b US.t -> b list -> hlist -> b list
+  = fun sink acc t -> match t with
+  | HNil -> List.rev acc
+  | HCons (src',x,t') ->
+      let acc = src'.convert sink x :: acc in
+      conv_hlist sink acc t'
+
+  let tuple t =
+    let convert sink x =
+      let hlist = t x in
+      sink.US.tuple (conv_hlist sink [] hlist) in
+    { convert; }
+
+  let pair a b =
+    { convert=(fun sink (x,y) ->
+      sink.US.tuple [a.convert sink x; b.convert sink y]);
+    }
+
+  let triple a b c =
+    { convert=(fun sink (x,y,z) ->
+      sink.US.tuple [a.convert sink x; b.convert sink y; c.convert sink z]);
+    }
+
+  let quad a b c d =
+    { convert=(fun sink (x,y,z,w) ->
+      sink.US.tuple [a.convert sink x; b.convert sink y;
+                  c.convert sink z; d.convert sink w]);
+    }
+
+  let sum f =
+    let convert sink x =
+      let name, l = f x in
+      sink.US.sum name (conv_hlist sink [] l) in
+    { convert; }
+
+  let sum0 f =
+    {convert=(fun sink x -> sink.US.sum (f x) []); }
+
+  let sum_fix f =
+    let rec convert : type b. b US.t -> 'r -> b
+    = fun sink x ->
+        (* evaluate src, and use it to convert x *)
+        (Lazy.force src).convert sink x
+    and src = lazy (sum (f {convert})) in
+    Lazy.force src
+
+  let opt src = sum (function
+      | Some x -> "some", hcons src x hnil
+      | None -> "none", hnil)
+end
+
+let into src sink x = src.Source.convert sink x
+
 module Sink = struct
   (** A specific sink that requires a given shape to produce
       a value of type 'a *)
@@ -155,264 +288,124 @@ module Sink = struct
     | List _ -> ExpectList
     | (Fix f) as sink -> expected (f sink)
     | Map (sink', _) -> expected sink'
-
-  (** Universal sink, such as a serialization format *)
-  module Universal = struct
-    type 'a t = {
-      unit_ : 'a;
-      bool_ : bool -> 'a;
-      float_ : float -> 'a;
-      int_ : int -> 'a;
-      string_ : string -> 'a;
-      list_ : 'a list -> 'a;
-      record : (string*'a) list -> 'a;
-      tuple : 'a list -> 'a;
-      sum : string -> 'a list -> 'a;
-    }
-  end
 end
 
-module Source = struct
-  (** A specific source that follows the shape of the type 'a *)
-  type 'a t =
-    | Unit : unit t
-    | Bool : bool t
-    | Float : float t
-    | Int : int t
-    | String : string t
-    | List : 'a t -> 'a list t
-    | Record : 'a record_src -> 'a t
-    | 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
+module UniversalSource = struct
+  type 'a t = {
+    visit : 'b. 'b Sink.t -> 'a -> 'b;
+  }
 
-  and 'r record_src =
-    | RecordField : string * ('r -> 'a) * 'a t * 'r record_src -> 'r record_src
-    | RecordStop : 'r record_src
+  let rec unit_ : type b. b Sink.t -> b
+  = fun sink -> match sink with
+    | Sink.Unit -> ()
+    | Sink.Int -> 0
+    | Sink.Map (sink', f) -> f (unit_ sink')
+    | Sink.Fix f -> unit_ (f sink)
+    | _ -> __error "get Unit, but expected %s" (Sink.__expected sink)
 
-  and 't tuple_src =
-    | TupleField : 'a t * ('t -> 'a) * 't tuple_src -> 't tuple_src
-    | TupleStop : 't tuple_src
+  let rec bool_ : type b. b Sink.t -> bool -> b
+  = fun sink b -> match sink with
+    | Sink.Bool -> b
+    | Sink.Int -> if b then 1 else 0
+    | Sink.String -> string_of_bool b
+    | Sink.Map (sink', f) -> f (bool_ sink' b)
+    | Sink.Fix f -> bool_ (f sink) b
+    | _ -> __error "get Bool, but expected %s" (Sink.__expected sink)
 
-  and sum_src =
-    | SumCons : 'a t * 'a * sum_src -> sum_src
-    | SumNil : sum_src
+  let rec float_ : type b. b Sink.t -> float -> b
+  = fun sink x -> match sink with
+    | Sink.Float -> x
+    | Sink.String -> string_of_float x
+    | Sink.Map (sink', f) -> f (float_ sink' x)
+    | Sink.Fix f -> float_ (f sink) x
+    | _ -> __error "get Float, but expected %s" (Sink.__expected sink)
 
-  let unit_ = Unit
-  let bool_ = Bool
-  let float_ = Float
-  let int_ = Int
-  let string_ = String
-  let list_ e = List e
+  let rec int_ : type b. b Sink.t -> int -> b
+  = fun sink i -> match sink with
+    | Sink.Int -> i
+    | Sink.Bool -> i <> 0
+    | Sink.String -> string_of_int i
+    | Sink.Map (sink', f) -> f (int_ sink' i)
+    | Sink.Fix f -> int_ (f sink) i
+    | _ -> __error "get Int, but expected %s" (Sink.__expected sink)
 
-  let map f src = Map (src, f)
-  let array_ src = map Array.to_list (list_ src)
+  let rec string_ : type b. b Sink.t -> string -> b
+  = fun sink s -> match sink with
+    | Sink.String -> s
+    | Sink.Int ->
+      begin try int_of_string s
+      with Invalid_argument _ -> __error "get String, but expected Int"
+      end
+    | Sink.Bool ->
+      begin try bool_of_string s
+      with Invalid_argument _ -> __error "get String, but expected Bool"
+      end
+    | Sink.Float ->
+      begin try float_of_string s
+      with Invalid_argument _ -> __error "get String, but expected Float"
+      end
+    | Sink.Map (sink', f) -> f (string_ sink' s)
+    | Sink.Fix f -> string_ (f sink) s
+    | _ -> __error "get String, but expected %s" (Sink.__expected sink)
 
-  let field name get src' cont =
-    RecordField (name,get,src',cont)
-  let record_stop = RecordStop
-  let record r = Record r
-  let record_fix f =
-    Fix (fun r -> Record (f r))
+  let rec list_ : type b. src:'a t -> b Sink.t -> 'a list -> b
+  = fun ~src sink l -> match sink with
+    | Sink.List f ->
+      f (fun sink' -> List.map (src.visit sink') l)
+    | Sink.Tuple _ -> tuple ~src sink l
+    | Sink.Map (sink', f) -> f (list_ ~src sink' l)
+    | Sink.Fix f -> list_ ~src (f sink) l
+    | _ -> __error "get List, but expected %s" (Sink.__expected sink)
 
-  let tuple_field src get cont = TupleField (src,get,cont)
-  let tuple_stop = TupleStop
-  let tuple t = Tuple t
+  and record : type b. src:'a t -> b Sink.t -> (string*'a) list -> b
+  = fun ~src sink l -> match sink with
+    | Sink.Record r ->
+      (* fold over the expected record fields *)
+      let rec build_record 
+      = function
+        | Sink.RecordStop x -> x
+        | Sink.RecordField (name, sink', cont) ->
+            let src_field = _get_field l name in
+            let sink_field = src.visit sink' src_field in
+            build_record (cont sink_field)
+      in build_record r
+    | Sink.Map (sink', f) -> f (record ~src sink' l)
+    | Sink.Fix f -> record ~src (f sink) l
+    | _ -> __error "get Record, but expected %s" (Sink.__expected sink)
 
-  let pair a b =
-    tuple (tuple_field a fst (tuple_field b snd tuple_stop))
+  and build_hlist : 't. src:'a t -> 'a list -> 't Sink.hlist -> 't
+      = fun ~src l t_sink -> match l, t_sink with
+        | [], Sink.HNil t -> t
+        | [], _ ->
+            __error "not enough tuple components"
+        | _::_, Sink.HNil _ ->
+            __error "too many tuple components (%d too many)" (List.length l)
+        | x::l', Sink.HCons (sink', cont) ->
+            let y = src.visit sink' x in
+            build_hlist ~src l' (cont y)
 
-  let triple a b c =
-    tuple
-    (tuple_field a (fun (a,b,c) -> a)
-      (tuple_field b (fun (a,b,c) -> b)
-        (tuple_field c (fun (a,b,c) -> c)
-          tuple_stop)))
+  and tuple : type b. src:'a t -> b Sink.t -> 'a list -> b
+  = fun ~src sink l -> match sink with
+    | Sink.Tuple t_sink ->
+      (* fold over the expected tuple component *)
+      build_hlist ~src l t_sink
+    | Sink.List _ -> list_ ~src sink l  (* adapt *)
+    | Sink.Map (sink', f) -> f (tuple ~src sink' l)
+    | Sink.Fix f -> tuple ~src (f sink) l
+    | _ -> __error "get Tuple, but expected %s" (Sink.__expected sink)
 
-  let quad a b c d =
-    tuple
-    (tuple_field a (fun (a,b,c,d) -> a)
-      (tuple_field b (fun (a,b,c,d) -> b)
-        (tuple_field c (fun (a,b,c,d) -> c)
-          (tuple_field d (fun (a,b,c,d) -> d)
-            tuple_stop))))
-
-  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
-      | None -> "none", sum_nil)
-
-  (* function to look up the given name in an association list *)
-  let _get_field l name =
-    try List.assoc name l
-    with Not_found ->
-      __error "record field %s not found in source" name
-
-  module Universal = struct
-    type 'a t = {
-      visit : 'b. 'b Sink.t -> 'a -> 'b;
-    }
-
-    let rec unit_ : type b. b Sink.t -> b
-    = fun sink -> match sink with
-      | Sink.Unit -> ()
-      | Sink.Int -> 0
-      | Sink.Map (sink', f) -> f (unit_ sink')
-      | Sink.Fix f -> unit_ (f sink)
-      | _ -> __error "get Unit, but expected %s" (Sink.__expected sink)
-
-    let rec bool_ : type b. b Sink.t -> bool -> b
-    = fun sink b -> match sink with
-      | Sink.Bool -> b
-      | Sink.Int -> if b then 1 else 0
-      | Sink.String -> string_of_bool b
-      | Sink.Map (sink', f) -> f (bool_ sink' b)
-      | Sink.Fix f -> bool_ (f sink) b
-      | _ -> __error "get Bool, but expected %s" (Sink.__expected sink)
-
-    let rec float_ : type b. b Sink.t -> float -> b
-    = fun sink x -> match sink with
-      | Sink.Float -> x
-      | Sink.String -> string_of_float x
-      | Sink.Map (sink', f) -> f (float_ sink' x)
-      | Sink.Fix f -> float_ (f sink) x
-      | _ -> __error "get Float, but expected %s" (Sink.__expected sink)
-
-    let rec int_ : type b. b Sink.t -> int -> b
-    = fun sink i -> match sink with
-      | Sink.Int -> i
-      | Sink.Bool -> i <> 0
-      | Sink.String -> string_of_int i
-      | Sink.Map (sink', f) -> f (int_ sink' i)
-      | Sink.Fix f -> int_ (f sink) i
-      | _ -> __error "get Int, but expected %s" (Sink.__expected sink)
-
-    let rec string_ : type b. b Sink.t -> string -> b
-    = fun sink s -> match sink with
-      | Sink.String -> s
-      | Sink.Int ->
-        begin try int_of_string s
-        with Invalid_argument _ -> __error "get String, but expected Int"
-        end
-      | Sink.Bool ->
-        begin try bool_of_string s
-        with Invalid_argument _ -> __error "get String, but expected Bool"
-        end
-      | Sink.Float ->
-        begin try float_of_string s
-        with Invalid_argument _ -> __error "get String, but expected Float"
-        end
-      | Sink.Map (sink', f) -> f (string_ sink' s)
-      | Sink.Fix f -> string_ (f sink) s
-      | _ -> __error "get String, but expected %s" (Sink.__expected sink)
-
-    let rec list_ : type b. src:'a t -> b Sink.t -> 'a list -> b
-    = fun ~src sink l -> match sink with
-      | Sink.List f ->
-        f (fun sink' -> List.map (src.visit sink') l)
-      | Sink.Tuple _ -> tuple ~src sink l
-      | Sink.Map (sink', f) -> f (list_ ~src sink' l)
-      | Sink.Fix f -> list_ ~src (f sink) l
-      | _ -> __error "get List, but expected %s" (Sink.__expected sink)
-
-    and record : type b. src:'a t -> b Sink.t -> (string*'a) list -> b
-    = fun ~src sink l -> match sink with
-      | Sink.Record r ->
-        (* fold over the expected record fields *)
-        let rec build_record 
-        = function
-          | Sink.RecordStop x -> x
-          | Sink.RecordField (name, sink', cont) ->
-              let src_field = _get_field l name in
-              let sink_field = src.visit sink' src_field in
-              build_record (cont sink_field)
-        in build_record r
-      | Sink.Map (sink', f) -> f (record ~src sink' l)
-      | Sink.Fix f -> record ~src (f sink) l
-      | _ -> __error "get Record, but expected %s" (Sink.__expected sink)
-
-    and build_hlist : 't. src:'a t -> 'a list -> 't Sink.hlist -> 't
-        = fun ~src l t_sink -> match l, t_sink with
-          | [], Sink.HNil t -> t
-          | [], _ ->
-              __error "not enough tuple components"
-          | _::_, Sink.HNil _ ->
-              __error "too many tuple components (%d too many)" (List.length l)
-          | x::l', Sink.HCons (sink', cont) ->
-              let y = src.visit sink' x in
-              build_hlist ~src l' (cont y)
-
-    and tuple : type b. src:'a t -> b Sink.t -> 'a list -> b
-    = fun ~src sink l -> match sink with
-      | Sink.Tuple t_sink ->
-        (* fold over the expected tuple component *)
-        build_hlist ~src l t_sink
-      | Sink.List _ -> list_ ~src sink l  (* adapt *)
-      | Sink.Map (sink', f) -> f (tuple ~src sink' l)
-      | Sink.Fix f -> tuple ~src (f sink) l
-      | _ -> __error "get Tuple, but expected %s" (Sink.__expected sink)
-
-    and sum : type b. src:'a t -> b Sink.t -> string -> 'a list -> b
-    = fun ~src sink name s -> match sink with
-      | Sink.Sum f ->
-          let l_sink = f name in
-          build_hlist ~src s l_sink
-      | Sink.Map (sink', f) -> f (sum ~src sink' name s)
-      | Sink.Fix f -> sum ~src (f sink) name s
-      | _ -> __error "get Sum(%s), but expected %s" name (Sink.__expected sink)
-  end
+  and sum : type b. src:'a t -> b Sink.t -> string -> 'a list -> b
+  = fun ~src sink name s -> match sink with
+    | Sink.Sum f ->
+        let l_sink = f name in
+        build_hlist ~src s l_sink
+    | Sink.Map (sink', f) -> f (sum ~src sink' name s)
+    | Sink.Fix f -> sum ~src (f sink) name s
+    | _ -> __error "get Sum(%s), but expected %s" name (Sink.__expected sink)
 end
 
-let rec into : type a b. a Source.t -> b Sink.Universal.t -> a -> b =
-  let open Sink.Universal in
-  fun src sink x -> match src with
-  | Source.Unit -> sink.unit_
-  | Source.Bool -> sink.bool_ x
-  | Source.Float -> sink.float_ x
-  | Source.Int -> sink.int_ x
-  | Source.String -> sink.string_ x
-  | Source.List src' ->
-      let l = List.map (into src' sink) x in
-      sink.list_ l
-  | Source.Record r ->
-      let rec conv_fields : (string*b)list -> a Source.record_src -> b
-      = fun acc r -> match r with
-      | Source.RecordStop -> sink.record (List.rev acc)
-      | Source.RecordField (name,get,src',r') ->
-          let acc = (name, into src' sink (get x)) :: acc in
-          conv_fields acc r'
-      in conv_fields [] r
-  | Source.Tuple t ->
-      let rec conv_tuple : b list -> a Source.tuple_src -> b
-      = fun acc t -> match t with
-      | Source.TupleStop -> sink.tuple (List.rev acc)
-      | Source.TupleField (src',get,t') ->
-          let acc = into src' sink (get x) :: acc in
-          conv_tuple acc t'
-      in conv_tuple [] t
-  | Source.Sum f ->
-      let rec conv_sum : string -> b list -> Source.sum_src -> b
-      = fun name acc sum -> match sum with
-      | Source.SumNil -> sink.sum name (List.rev acc)
-      | Source.SumCons (src',x,sum') ->
-          let acc = into src' sink x :: acc in
-          conv_sum name acc sum'
-      in
-      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.t) (sink:'b Sink.t) (x:'a) : 'b =
-  src.Source.Universal.visit sink x
+let from (src:'a UniversalSource.t) (sink:'b Sink.t) (x:'a) : 'b =
+  src.UniversalSource.visit sink x
 
 (** {6 Exemples} *)
 
@@ -428,7 +421,7 @@ module Json = struct
   ]
 
   let source =
-    let module U = Source.Universal in
+    let module U = UniversalSource in
     let rec visit : type b. b Sink.t -> t -> b =
     fun sink x -> match x with
       | `Int i -> U.int_ sink i
@@ -450,8 +443,8 @@ module Json = struct
     and src = { U.visit=visit; } in
     src
 
-  let sink : t Sink.Universal.t =
-    let open Sink.Universal in
+  let sink : t UniversalSink.t =
+    let open UniversalSink in
     { unit_ = `Null;
       bool_ = (fun b -> `Bool b);
       float_ = (fun f -> `Float f);
@@ -472,7 +465,7 @@ module Sexp = struct
     | List of t list
 
   let source =
-    let module U = Source.Universal in
+    let module U = UniversalSource in
     let rec visit : type b. b Sink.t -> t -> b =
     fun sink x -> match x, Sink.expected sink with
       | Atom s, Sink.ExpectSum -> U.sum ~src sink s []
@@ -489,7 +482,7 @@ module Sexp = struct
     src
 
   let sink =
-    let open Sink.Universal in
+    let open UniversalSink in
     { unit_ = List [];
       bool_ = (fun b -> Atom (string_of_bool b));
       float_ = (fun f -> Atom (string_of_float f));
@@ -521,7 +514,7 @@ module Bencode = struct
     | Assoc of (string * t) list
 
   let source =
-    let module U = Source.Universal in
+    let module U = UniversalSource in
     let rec visit : type b. b Sink.t -> t -> b =
     fun sink x -> match x, Sink.expected sink with
       | String s, Sink.ExpectSum -> U.sum ~src sink s []
@@ -536,7 +529,7 @@ module Bencode = struct
     src
 
   let sink =
-    let open Sink.Universal in
+    let open UniversalSink in
     { unit_ = Int 0;
       bool_ = (fun b -> Int (if b then 1 else 0));
       float_ = (fun f -> String (string_of_float f));
@@ -571,7 +564,7 @@ module Point = struct
         yield_record {x;y;color;prev}
       ))
 
-  let source =
+  let rec source =
     Source.(record_fix
       (fun self ->
         field "x" (fun p -> p.x) int_ @@
@@ -605,9 +598,9 @@ module Lambda = struct
 
   let source = Source.(sum_fix
     (fun self t -> match t with
-        | Var s -> "var", sum_cons string_ s @@ sum_nil
-        | App (t1, t2) -> "app", sum_cons self t1 @@ sum_cons self t2 @@ sum_nil
-        | Lambda (s, t) -> "lam", sum_cons string_ s @@ sum_cons self t @@ sum_nil
+        | Var s -> "var", hcons string_ s @@ hnil
+        | App (t1, t2) -> "app", hcons self t1 @@ hcons self t2 @@ hnil
+        | Lambda (s, t) -> "lam", hcons string_ s @@ hcons self t @@ hnil
       ))
 
   let sink = Sink.(sum_fix
diff --git a/conv.mli b/conv.mli
index d66b1030..25b8f977 100644
--- a/conv.mli
+++ b/conv.mli
@@ -28,12 +28,73 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 exception ConversionFailure of string
 
+(** {6 Universal sink}
+
+Some type any valye can be traducted into, such as a serialization format
+like JSON or B-encode. *)
+module UniversalSink : sig
+  type 'a t = {
+    unit_ : 'a;
+    bool_ : bool -> 'a;
+    float_ : float -> 'a;
+    int_ : int -> 'a;
+    string_ : string -> 'a;
+    list_ : 'a list -> 'a;
+    record : (string*'a) list -> 'a;
+    tuple : 'a list -> 'a;
+    sum : string -> 'a list -> 'a;
+  }
+end
+
+(** {6 Sources}
+A 'a source is used to build values of some type 'b, given a 'b sink
+description of how to build values of type 'b. *)
+module Source : sig
+  type 'a t = {
+    convert : 'b. 'b UniversalSink.t -> 'a -> 'b;
+  }
+
+  type 'r record_src
+
+  type hlist =
+    | HNil : hlist
+    | HCons : 'a t * 'a * hlist -> hlist
+
+  val hnil : hlist
+  val hcons : 'a t -> 'a -> hlist -> hlist
+
+  val unit_ : unit t
+  val bool_ : bool t
+  val float_ : float t
+  val int_ : int t
+  val string_ : string t
+  val list_ : 'a t -> 'a list t
+
+  val map : ('a -> 'b) -> 'b t -> 'a t
+  val array_ : 'a t -> 'a array t
+
+  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
+
+  val tuple : ('a -> hlist) -> 'a t
+
+  val pair : 'a t -> 'b t -> ('a * 'b) t
+  val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
+  val quad : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t
+
+  val sum : ('a -> string * hlist) -> 'a t
+  val sum0 : ('a -> string) -> 'a t
+  val sum_fix : ('a t -> 'a -> string * hlist) -> 'a t
+
+  val opt : 'a t -> 'a option t
+end
+
 (** {6 Sinks}
-A sink is used to traverse values of some type 'a *)
+A sink is used to produce values of type 'a from a universal source. *)
 module Sink : sig
-  (** A specific sink that requires a given shape to produce
-     a value of type 'a *)
-  type 'a t
+  type 'a t  (** How to produce values of type 'a *)
 
   and 'r record_sink =
     | RecordField : string * 'a t * ('a -> 'r record_sink) -> 'r record_sink
@@ -87,96 +148,36 @@ module Sink : sig
   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 *)
-  module Universal : sig
-    type 'a t = {
-      unit_ : 'a;
-      bool_ : bool -> 'a;
-      float_ : float -> 'a;
-      int_ : int -> 'a;
-      string_ : string -> 'a;
-      list_ : 'a list -> 'a;
-      record : (string*'a) list -> 'a;
-      tuple : 'a list -> 'a;
-      sum : string -> 'a list -> 'a;
-    }
-  end
 end
 
-(** {6 Sources}
-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
+(** {6 Universal source}
 
-  and 'r record_src =
-    | RecordField : string * ('r -> 'a) * 'a t * 'r record_src -> 'r record_src
-    | RecordStop : 'r record_src
+source from type 'a, where 'a is typically a serialization
+format. This is used to translate from 'a to some other type. 
+A universal format should use the provided combinators to
+interface with {!Sink.t} values *)
+module UniversalSource : sig
+  type 'a t = {
+    visit : 'b. 'b Sink.t -> 'a -> 'b;
+  }
 
-  and 't tuple_src =
-    | TupleField : 'a t * ('t -> 'a) * 't tuple_src -> 't tuple_src
-    | TupleStop : 't tuple_src
-
-  and sum_src =
-    | SumCons : 'a t * 'a * sum_src -> sum_src
-    | SumNil : sum_src
-
-  val unit_ : unit t
-  val bool_ : bool t
-  val float_ : float t
-  val int_ : int t
-  val string_ : string t
-  val list_ : 'a t -> 'a list t
-
-  val map : ('b -> 'a) -> 'a t -> 'b t
-  val array_ : 'a t -> 'a array t
-
-  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
-
-  val tuple_field : 'a t -> ('t -> 'a) -> 't tuple_src -> 't tuple_src
-  val tuple_stop : 't tuple_src
-  val tuple : 't tuple_src -> 't t
-
-  val pair : 'a t -> 'b t -> ('a * 'b) t
-  val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
-  val quad : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t
-
-  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
-
-  (** Universal source from type 'a. A universal type should use
-      combinators to implement the visitor pattern. *)
-  module Universal : sig
-    type 'a t = {
-      visit : 'b. 'b Sink.t -> 'a -> 'b;
-    }
-
-    val unit_ : 'b Sink.t -> 'b
-    val bool_ : 'b Sink.t -> bool -> 'b
-    val float_ : 'b Sink.t -> float -> 'b
-    val int_ : 'b Sink.t -> int -> 'b
-    val string_ : 'b Sink.t -> string -> 'b
-    val list_ : src:'a t -> 'b Sink.t -> 'a list -> 'b
-    val record : src:'a t -> 'b Sink.t -> (string*'a) list -> 'b
-    val tuple : src:'a t -> 'b Sink.t -> 'a list -> 'b
-    val sum : src:'a t -> 'b Sink.t -> string -> 'a list -> 'b
-  end
+  val unit_ : 'b Sink.t -> 'b
+  val bool_ : 'b Sink.t -> bool -> 'b
+  val float_ : 'b Sink.t -> float -> 'b
+  val int_ : 'b Sink.t -> int -> 'b
+  val string_ : 'b Sink.t -> string -> 'b
+  val list_ : src:'a t -> 'b Sink.t -> 'a list -> 'b
+  val record : src:'a t -> 'b Sink.t -> (string*'a) list -> 'b
+  val tuple : src:'a t -> 'b Sink.t -> 'a list -> 'b
+  val sum : src:'a t -> 'b Sink.t -> string -> 'a list -> 'b
 end
 
 (** {6 Conversion Functions} *)
 
-val into : 'a Source.t -> 'b Sink.Universal.t -> 'a -> 'b
+val into : 'a Source.t -> 'b UniversalSink.t -> 'a -> 'b
   (** Conversion to universal sink *)
 
-val from : 'a Source.Universal.t -> 'b Sink.t -> 'a -> 'b
+val from : 'a UniversalSource.t -> 'b Sink.t -> 'a -> 'b
   (** Conversion from universal source *)
 
 (* TODO for format conversion
@@ -196,8 +197,8 @@ module Json : sig
     | `Assoc of (string * t) list
   ]
 
-  val source : t Source.Universal.t
-  val sink : t Sink.Universal.t
+  val source : t UniversalSource.t
+  val sink : t UniversalSink.t
 end
 
 module Sexp : sig
@@ -205,8 +206,8 @@ module Sexp : sig
     | Atom of string
     | List of t list
 
-  val source : t Source.Universal.t
-  val sink : t Sink.Universal.t
+  val source : t UniversalSource.t
+  val sink : t UniversalSink.t
   val fmt : Format.formatter -> t -> unit (* for debug *)
 end
 
@@ -217,8 +218,8 @@ module Bencode : sig
     | List of t list
     | Assoc of (string * t) list
 
-  val source : t Source.Universal.t
-  val sink : t Sink.Universal.t
+  val source : t UniversalSource.t
+  val sink : t UniversalSink.t
 end
 
 (** Tests *)