feat(sexp): functorize the parser/printer

src/sexp/CCSexp.ml

@@ -9,56 +9,31 @@ type 'a or_error = ('a, string) Result.result
 type 'a sequence = ('a -> unit) -> unit
 type 'a gen = unit -> 'a option
 
-type t = [
+module type SEXP = CCSexp_intf.SEXP
-  | `Atom of string
+module type S = CCSexp_intf.S
-  | `List of t list
-]
-type sexp = t
 
 let equal_string (a : string) b = Stdlib.(=) a b
-
-let rec equal a b = match a, b with
-  | `Atom s1, `Atom s2 ->
-    equal_string s1 s2
-  | `List l1, `List l2 ->
-    begin try List.for_all2 equal l1 l2 with Invalid_argument _ -> false end
-  | `Atom _, _ | `List _, _ -> false
-
 let compare_string (a : string) b = Stdlib.compare a b
 
-let rec compare_list a b = match a, b with
+module Make(Sexp : SEXP) = struct
-  | [], [] -> 0
+  type t = Sexp.t
-  | [], _::_ -> -1
+  type sexp = t
-  | _::_, [] -> 1
-  | x::xs, y::ys ->
-    begin match compare x y with
-      | 0 -> compare_list xs ys
-      | c -> c
-    end
 
-and compare a b = match a, b with
+  let of_int x = Sexp.atom (string_of_int x)
-  | `Atom s1, `Atom s2 -> compare_string s1 s2
+  let of_float x = Sexp.atom (string_of_float x)
-  | `List l1, `List l2 -> compare_list l1 l2
+  let of_bool x = Sexp.atom (string_of_bool x)
-  | `Atom _, _ -> -1
+  let atom x = Sexp.atom x
-  | `List _, _ -> 1
+  let of_unit = Sexp.list []
+  let of_list l = Sexp.list l
+  let of_rev_list l = Sexp.list (List.rev l)
+  let of_pair (x,y) = Sexp.list [x;y]
+  let of_triple (x,y,z) = Sexp.list [x;y;z]
+  let of_quad (x,y,z,u) = Sexp.list [x;y;z;u]
 
-let hash a = Hashtbl.hash a
+  let of_variant name args = Sexp.list (Sexp.atom name :: args)
-
+  let of_field name t = Sexp.list [Sexp.atom name; t]
-let of_int x = `Atom (string_of_int x)
-let of_float x = `Atom (string_of_float x)
-let of_bool x = `Atom (string_of_bool x)
-let atom x = `Atom x
-let of_unit = `List []
-let of_list l = `List l
-let of_rev_list l = `List (List.rev l)
-let of_pair (x,y) = `List[x;y]
-let of_triple (x,y,z) = `List[x;y;z]
-let of_quad (x,y,z,u) = `List[x;y;z;u]
-
-let of_variant name args = `List (`Atom name :: args)
-let of_field name t = `List [`Atom name; t]
   let of_record l =
-  `List (List.map (fun (n,x) -> of_field n x) l)
+    Sexp.list (List.map (fun (n,x) -> of_field n x) l)
 
   (** {2 Printing} *)
 
@@ -85,46 +60,55 @@ let _must_escape s =
       false
     with Exit -> true
 
-let rec to_buf b t = match t with
+  let rec to_buf b t =
-  | `Atom s when _must_escape s -> Printf.bprintf b "\"%s\"" (String.escaped s)
+    Sexp.match_ t
-  | `Atom s -> Buffer.add_string b s
+      ~atom:(fun s ->
-  | `List [] -> Buffer.add_string b "()"
+          if _must_escape s then Printf.bprintf b "\"%s\"" (String.escaped s)
-  | `List [x] -> Printf.bprintf b "(%a)" to_buf x
+          else Buffer.add_string b s)
-  | `List l ->
+      ~list:(function
+          | [] -> Buffer.add_string b "()"
+          | [x] -> Printf.bprintf b "(%a)" to_buf x
+          | l ->
             Buffer.add_char b '(';
             List.iteri
               (fun i t' -> (if i > 0 then Buffer.add_char b ' '; to_buf b t'))
               l;
-    Buffer.add_char b ')'
+            Buffer.add_char b ')')
 
   let to_string t =
     let b = Buffer.create 128 in
     to_buf b t;
     Buffer.contents b
 
-let rec pp fmt t = match t with
+  let rec pp fmt t =
-  | `Atom s when _must_escape s -> Format.fprintf fmt "\"%s\"" (String.escaped s)
+    Sexp.match_ t
-  | `Atom s -> Format.pp_print_string fmt s
+      ~atom:(fun s ->
-  | `List [] -> Format.pp_print_string fmt "()"
+          if _must_escape s then Format.fprintf fmt "\"%s\"" (String.escaped s)
-  | `List [x] -> Format.fprintf fmt "@[<hov2>(%a)@]" pp x
+          else Format.pp_print_string fmt s)
-  | `List l ->
+      ~list:(function
+          | [] -> Format.pp_print_string fmt "()"
+          | [x] -> Format.fprintf fmt "@[<hov2>(%a)@]" pp x
+          | l ->
             Format.fprintf fmt "@[<hov1>(";
             List.iteri
               (fun i t' -> (if i > 0 then Format.fprintf fmt "@ "; pp fmt t'))
               l;
-    Format.fprintf fmt ")@]"
+            Format.fprintf fmt ")@]")
 
-let rec pp_noindent fmt t = match t with
+  let rec pp_noindent fmt t =
-  | `Atom s when _must_escape s -> Format.fprintf fmt "\"%s\"" (String.escaped s)
+    Sexp.match_ t
-  | `Atom s -> Format.pp_print_string fmt s
+      ~atom:(fun s ->
-  | `List [] -> Format.pp_print_string fmt "()"
+    if _must_escape s then Format.fprintf fmt "\"%s\"" (String.escaped s)
-  | `List [x] -> Format.fprintf fmt "(%a)" pp_noindent x
+    else Format.pp_print_string fmt s)
-  | `List l ->
+      ~list:(function
+          | [] -> Format.pp_print_string fmt "()"
+          | [x] -> Format.fprintf fmt "(%a)" pp_noindent x
+          | l ->
             Format.pp_print_char fmt '(';
             List.iteri
               (fun i t' -> (if i > 0 then Format.pp_print_char fmt ' '; pp_noindent fmt t'))
               l;
-    Format.pp_print_char fmt ')'
+            Format.pp_print_char fmt ')')
 
   let to_chan oc t =
     let fmt = Format.formatter_of_out_channel oc in
@@ -199,12 +183,12 @@ module Decoder = struct
           junk t;
           let _u = expr() in (* discard next sexp *)
           expr()
-      | L.ATOM s -> junk t; `Atom s
+        | L.ATOM s -> junk t; Sexp.atom s
         | L.LIST_OPEN ->
           junk t;
           let l = lst [] in
           begin match cur t with
-          | L.LIST_CLOSE -> junk t; `List l
+            | L.LIST_CLOSE -> junk t; Sexp.list l
             | _ -> error_ t.buf "expected ')'"
           end
         | L.LIST_CLOSE -> error_ t.buf "expected expression"
@@ -231,6 +215,76 @@ let parse_string s : t or_error =
       | Yield x -> Result.Ok x
       | Fail s -> Result.Error s
 
+  let parse_chan ic : sexp or_error =
+    let buf = Lexing.from_channel ic in
+    let d = Decoder.of_lexbuf buf in
+    match Decoder.next d with
+      | End -> Result.Error "unexpected end of file"
+      | Yield x -> Result.Ok x
+      | Fail e -> Result.Error e
+
+  let parse_chan_list ic =
+    let buf = Lexing.from_channel ic in
+    let d = Decoder.of_lexbuf buf in
+    let rec iter acc = match Decoder.next d with
+      | End -> Result.Ok (List.rev acc)
+      | Yield x -> iter (x::acc)
+      | Fail e -> Result.Error e
+    in
+    iter []
+
+  let parse_chan_gen ic =
+    let buf = Lexing.from_channel ic in
+    let d = Decoder.of_lexbuf buf in
+    fun () -> match Decoder.next d with
+      | End -> None
+      | Fail e -> Some (Result.Error e)
+      | Yield x -> Some (Result.Ok x)
+
+  let parse_file filename = _with_in filename parse_chan
+
+  let parse_file_list filename = _with_in filename parse_chan_list
+end
+
+type t = [
+  | `Atom of string
+  | `List of t list
+]
+
+let rec equal a b = match a, b with
+  | `Atom s1, `Atom s2 ->
+    equal_string s1 s2
+  | `List l1, `List l2 ->
+    begin try List.for_all2 equal l1 l2 with Invalid_argument _ -> false end
+  | `Atom _, _ | `List _, _ -> false
+
+let rec compare_list a b = match a, b with
+  | [], [] -> 0
+  | [], _::_ -> -1
+  | _::_, [] -> 1
+  | x::xs, y::ys ->
+    begin match compare x y with
+      | 0 -> compare_list xs ys
+      | c -> c
+    end
+
+and compare a b = match a, b with
+  | `Atom s1, `Atom s2 -> compare_string s1 s2
+  | `List l1, `List l2 -> compare_list l1 l2
+  | `Atom _, _ -> -1
+  | `List _, _ -> 1
+
+include (Make(struct
+    type t_ = t
+    type t = t_
+    let atom x = `Atom x
+    let list x = `List x
+
+    let match_ x ~atom ~list = match x with
+      | `Atom x -> atom x
+      | `List l -> list l
+  end) : S with type t := t)
+
 (*$T
   CCResult.to_opt (parse_string "(abc d/e/f \"hello \\\" () world\" )") <> None
   CCResult.to_opt (parse_string "(abc ( d e ffff   ) \"hello/world\")") <> None
@@ -282,33 +336,3 @@ let parse_string s : t or_error =
 (*$Q & ~count:100
     sexp_gen (fun s -> sexp_valid s ==> (to_string s |> parse_string = Result.Ok s))
 *)
-
-let parse_chan ic : sexp or_error =
-  let buf = Lexing.from_channel ic in
-  let d = Decoder.of_lexbuf buf in
-  match Decoder.next d with
-    | End -> Result.Error "unexpected end of file"
-    | Yield x -> Result.Ok x
-    | Fail e -> Result.Error e
-
-let parse_chan_list ic =
-  let buf = Lexing.from_channel ic in
-  let d = Decoder.of_lexbuf buf in
-  let rec iter acc = match Decoder.next d with
-    | End -> Result.Ok (List.rev acc)
-    | Yield x -> iter (x::acc)
-    | Fail e -> Result.Error e
-  in
-  iter []
-
-let parse_chan_gen ic =
-  let buf = Lexing.from_channel ic in
-  let d = Decoder.of_lexbuf buf in
-  fun () -> match Decoder.next d with
-    | End -> None
-    | Fail e -> Some (Result.Error e)
-    | Yield x -> Some (Result.Ok x)
-
-let parse_file filename = _with_in filename parse_chan
-
-let parse_file_list filename = _with_in filename parse_chan_list

src/sexp/CCSexp.mli

@@ -7,98 +7,30 @@ type 'a or_error = ('a, string) Result.result
 type 'a sequence = ('a -> unit) -> unit
 type 'a gen = unit -> 'a option
 
+(** {2 Abstract representation of S-expressions}
+
+    @since NEXT_RELEASE *)
+module type SEXP = CCSexp_intf.SEXP
+
+(** {2 Operations over S-expressions}
+
+    @since NEXT_RELEASE *)
+module type S = CCSexp_intf.S
+
+(** {2 Functorized operations}
+
+    This builds a parser and printer for S-expressions represented as
+    in the [Sexp] argument.
+
+    @since NEXT_RELEASE *)
+module Make(Sexp : SEXP) : S with type t = Sexp.t
+
 (** {2 Basics} *)
 
+(** A simple, structural representation of S-expressions. *)
 type t = [
   | `Atom of string
   | `List of t list
 ]
-type sexp = t
 
-val equal : t -> t -> bool
+include S with type t := t
-val compare : t -> t -> int
-val hash : t -> int
-
-val atom : string -> t  
-(** Build an atom directly from a string. *)
-
-val of_int : int -> t
-val of_bool : bool -> t
-val of_list : t list -> t
-val of_rev_list : t list -> t  
-(** Reverse the list. *)
-val of_float : float -> t
-val of_unit : t
-val of_pair : t * t -> t
-val of_triple : t * t * t -> t
-val of_quad : t * t * t * t -> t
-
-val of_variant : string -> t list -> t
-(** [of_variant name args] is used to encode algebraic variants
-    into a S-expr. For instance [of_variant "some" [of_int 1]]
-    represents the value [Some 1]. *)
-
-val of_field : string -> t -> t
-(** Used to represent one record field. *)
-
-val of_record : (string * t) list -> t
-(** Represent a record by its named fields. *)
-
-(** {2 Printing} *)
-
-val to_buf : Buffer.t -> t -> unit
-
-val to_string : t -> string
-
-val to_file : string -> t -> unit
-
-val to_file_seq : string -> t sequence -> unit
-(** Print the given sequence of expressions to a file. *)
-
-val to_chan : out_channel -> t -> unit
-
-val pp : Format.formatter -> t -> unit
-(** Pretty-printer nice on human eyes (including indentation). *)
-
-val pp_noindent : Format.formatter -> t -> unit
-(** Raw, direct printing as compact as possible. *)
-
-(** {2 Parsing} *)
-
-(** A parser of ['a] can return [Yield x] when it parsed a value,
-    or [Fail e] when a parse error was encountered, or
-    [End] if the input was empty. *)
-type 'a parse_result =
-  | Yield of 'a
-  | Fail of string
-  | End
-
-module Decoder : sig
-  type t
-  (** Decoder *)
-
-  val of_lexbuf : Lexing.lexbuf -> t
-
-  val next : t -> sexp parse_result
-  (** Parse the next S-expression or return an error if the input isn't
-      long enough or isn't a proper S-expression. *)
-end
-
-val parse_string : string -> t or_error
-(** Parse a string. *)
-
-val parse_chan : in_channel -> t or_error
-(** Parse a S-expression from the given channel. Can read more data than
-    necessary, so don't use this if you need finer-grained control (e.g.
-    to read something else {b after} the S-exp). *)
-
-val parse_chan_gen : in_channel -> t or_error gen
-(** Parse a channel into a generator of S-expressions. *)
-
-val parse_chan_list : in_channel -> t list or_error
-
-val parse_file : string -> t or_error
-(** Open the file and read a S-exp from it. *)
-
-val parse_file_list : string -> t list or_error
-(** Open the file and read a S-exp from it. *)