From 9d1843ecf896890d0ed30636ccade0b17663f29f Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Wed, 15 May 2013 15:11:54 +0200
Subject: [PATCH] Bij.{guard,fix} helpers

---
 bij.ml            | 22 ++++++++++++++++++++++
 bij.mli           | 14 ++++++++++++++
 tests/test_bij.ml | 12 +++++++-----
 3 files changed, 43 insertions(+), 5 deletions(-)

diff --git a/bij.ml b/bij.ml
index 916448d9..095fa2e7 100644
--- a/bij.ml
+++ b/bij.ml
@@ -36,6 +36,7 @@ type _ t =
   | Opt : 'a t -> 'a option t
   | Pair : 'a t * 'b t -> ('a * 'b) t
   | Triple : 'a t * 'b t * 'c t -> ('a * 'b * 'c) t
+  | Guard : ('a -> bool) * 'a t -> 'a t
   | Map : ('a -> 'b) * ('b -> 'a) * 'b t -> 'a t
   | Switch : ('a -> char * 'a inject_branch) * (char -> 'a extract_branch) -> 'a t
 and _ inject_branch =
@@ -57,10 +58,24 @@ let many l = Many l
 let opt t = Opt t
 let pair a b = Pair(a,b)
 let triple a b c = Triple (a,b,c)
+let guard f t = Guard (f, t)
 
 let map ~inject ~extract b = Map (inject, extract, b)
 let switch ~inject ~extract = Switch (inject, extract)
 
+(** {2 Helpers} *)
+
+let fix f =
+  let rec bij = lazy (f (fun () -> Lazy.force bij)) in
+  Lazy.force bij
+
+type 'a versioned = string * 'a
+
+let with_version v t =
+  pair (guard (fun v' -> v = v') string_) t
+
+(** {2 Exceptions} *)
+
 exception EOF
 
 exception EncodingError of string
@@ -263,6 +278,9 @@ module SexpEncode(Sink : SINK) = struct
         Sink.write_char sink ' ';
         encode bij_b b;
         Sink.write_char sink ')'
+      | Guard (check, bij'), _ ->
+        (if not (check x) then raise (EncodingError ("check failed")));
+        encode bij' x
       | Triple (bij_a, bij_b, bij_c), (a, b, c) ->
         Sink.write_char sink '(';
         encode bij_a a;
@@ -344,6 +362,10 @@ module SexpDecode(Source : SOURCE) = struct
         let c = decode bijc in
         decode_close ();
         a, b, c
+      | Guard (check, bij') ->
+        let x = decode bij' in
+        (if not (check x) then raise (DecodingError "check failed"));
+        x
       | Map (_, extract, bij') ->
         let x = decode bij' in
         extract x
diff --git a/bij.mli b/bij.mli
index c8c193ea..1abc6165 100644
--- a/bij.mli
+++ b/bij.mli
@@ -40,6 +40,8 @@ val many : 'a t -> 'a list t  (* non empty *)
 val opt : 'a t -> 'a option t
 val pair : 'a t -> 'b t -> ('a * 'b) t
 val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
+val guard : ('a -> bool) -> 'a t -> 'a t
+  (** Validate values at encoding and decoding *)
 
 val map : inject:('a -> 'b) -> extract:('b -> 'a) -> 'b t -> 'a t
 
@@ -55,6 +57,18 @@ val switch : inject:('a -> char * 'a inject_branch) ->
       type (the argument of the algebraic constructor);
       [extract] retrieves which type to parse based on the character. *)
 
+(** {2 Helpers} *)
+
+val fix : ((unit -> 'a t) -> 'a t) -> 'a t
+  (** Helper for recursive encodings *)
+
+type 'a versioned = string * 'a
+
+val with_version : string -> 'a t -> 'a versioned t
+  (** Guards the values with a given version *)
+
+(** {2 Exceptions} *)
+
 exception EOF
 
 exception EncodingError of string
diff --git a/tests/test_bij.ml b/tests/test_bij.ml
index f49b5ade..55b5c18a 100644
--- a/tests/test_bij.ml
+++ b/tests/test_bij.ml
@@ -32,18 +32,20 @@ type term =
   | App of term list
 
 let bij_term =
-  let rec mk_bij () =
+  let bij = fix
+    (fun bij ->
     switch
     ~inject:(function
       | Const s -> 'c', BranchTo (string_, s)
       | Int i -> 'i', BranchTo (int_, i)
-      | App l -> 'a', BranchTo (list_ (mk_bij ()), l))
+      | App l -> 'a', BranchTo (list_ (bij ()), l))
     ~extract:(function
       | 'c' -> BranchFrom (string_, fun x -> Const x)
       | 'i' -> BranchFrom (int_, fun x -> Int x)
-      | 'a' -> BranchFrom (list_ (mk_bij ()), fun l -> App l)
-      | _ -> raise (DecodingError "unexpected case switch"))
-  in mk_bij ()
+      | 'a' -> BranchFrom (list_ (bij ()), fun l -> App l)
+      | _ -> raise (DecodingError "unexpected case switch")))
+  in
+  bij
 
 let test_rec () =
   let t = App [Const "foo"; App [Const "bar"; Int 1; Int 2]; Int 3; Const "hello"] in