Build_info/Unit_info: support for sexp serialization

Author: vouillon

compiler/lib/build_info.ml

@@ -90,6 +90,20 @@ let parse s =
       in
       Some t
 
+let to_sexp info =
+  Sexp.List
+    (info
+    |> StringMap.bindings
+    |> List.map ~f:(fun (k, v) -> Sexp.List [ Atom k; Atom v ]))
+
+let from_sexp info =
+  let open Sexp.Util in
+  info
+  |> assoc
+  |> List.fold_left
+       ~f:(fun m (k, v) -> StringMap.add k (single string v) m)
+       ~init:StringMap.empty
+
 exception
   Incompatible_build_info of
     { key : string

compiler/lib/build_info.mli

@@ -34,6 +34,10 @@ val to_string : t -> string
 
 val parse : string -> t option
 
+val to_sexp : t -> Sexp.t
+
+val from_sexp : Sexp.t -> t
+
 val with_kind : t -> kind -> t
 
 exception

compiler/lib/sexp.ml

@@ -0,0 +1,161 @@
+(* ()#;"" space <-- reserved *)
+open Stdlib
+
+type t =
+  | Atom of string
+  | List of t list
+
+let reserved_char c =
+  match c with
+  | '\x00' .. ' ' | '(' | ')' | '#' | ';' | '"' | '\x7f' .. '\xff' -> true
+  | _ -> false
+
+let need_escaping s =
+  let len = String.length s in
+  len = 0
+  ||
+  let res = ref false in
+  for i = 0 to len - 1 do
+    res := !res || reserved_char s.[i]
+  done;
+  !res
+
+let should_quote c =
+  match c with
+  | '\x00' .. '\x1F' | '"' | '\\' | '\x7f' .. '\xff' -> true
+  | _ -> false
+
+let escape_to_buffer buf s =
+  let start = ref 0 in
+  let len = String.length s in
+  Buffer.add_char buf '"';
+  for i = 0 to len - 1 do
+    let c = s.[i] in
+    if should_quote c
+    then (
+      if !start < i then Buffer.add_substring buf s !start (i - !start);
+      Buffer.add_char buf '\\';
+      let c = Char.code c in
+      Buffer.add_uint8 buf ((c / 100) + 48);
+      Buffer.add_uint8 buf ((c / 10 mod 10) + 48);
+      Buffer.add_uint8 buf ((c mod 10) + 48);
+      start := i + 1)
+  done;
+  if !start < len then Buffer.add_substring buf s !start (len - !start);
+  Buffer.add_char buf '"'
+
+let rec add_to_buffer buf v =
+  match v with
+  | Atom s -> if need_escaping s then escape_to_buffer buf s else Buffer.add_string buf s
+  | List l ->
+      Buffer.add_char buf '(';
+      List.iteri
+        ~f:(fun i v' ->
+          if i > 0 then Buffer.add_char buf ' ';
+          add_to_buffer buf v')
+        l;
+      Buffer.add_char buf ')'
+
+let to_string v =
+  let b = Buffer.create 128 in
+  add_to_buffer b v;
+  Buffer.contents b
+
+let parse_error () = failwith "parse error"
+
+let rec parse buf s pos : t * int =
+  match s.[pos] with
+  | '(' -> parse_list buf s [] (pos + 1)
+  | '\"' ->
+      Buffer.clear buf;
+      parse_quoted_atom buf s (pos + 1) (pos + 1)
+  | _ -> parse_atom buf s pos pos
+
+and parse_list buf s acc pos =
+  match s.[pos] with
+  | ' ' -> parse_list buf s acc (pos + 1)
+  | ')' -> List (List.rev acc), pos + 1
+  | _ ->
+      let v, pos' = parse buf s pos in
+      parse_list buf s (v :: acc) pos'
+
+and parse_atom buf s pos0 pos =
+  if reserved_char s.[pos]
+  then (
+    if pos0 = pos then parse_error ();
+    Atom (String.sub s ~pos:pos0 ~len:(pos - pos0)), pos)
+  else parse_atom buf s pos0 (pos + 1)
+
+and parse_quoted_atom buf s pos0 pos =
+  match s.[pos] with
+  | '\"' ->
+      if pos0 < pos then Buffer.add_substring buf s pos0 (pos - pos0);
+      Atom (Buffer.contents buf), pos + 1
+  | '\\' ->
+      if pos0 < pos then Buffer.add_substring buf s pos0 (pos - pos0);
+      Buffer.add_uint8
+        buf
+        (((Char.code s.[pos + 1] - 48) * 100)
+        + ((Char.code s.[pos + 2] - 48) * 10)
+        + Char.code s.[pos + 3]
+        - 48);
+      parse_quoted_atom buf s (pos + 4) (pos + 4)
+  | _ -> parse_quoted_atom buf s pos0 (pos + 1)
+
+let from_string s =
+  let v, pos = parse (Buffer.create 16) s 0 in
+  if pos < String.length s then parse_error ();
+  v
+
+module Util = struct
+  let single f v =
+    match v with
+    | [ v ] -> f v
+    | _ -> assert false
+
+  let string v =
+    match v with
+    | Atom s -> s
+    | _ -> assert false
+
+  let assoc v =
+    match v with
+    | List l ->
+        List.map
+          ~f:(fun p ->
+            match p with
+            | List (Atom k :: v) -> k, v
+            | _ -> assert false)
+          l
+    | Atom _ -> assert false
+
+  let member nm v =
+    match v with
+    | Atom _ -> assert false
+    | List l ->
+        List.find_map
+          ~f:(fun p ->
+            match p with
+            | List (Atom nm' :: v) when String.equal nm nm' -> Some v
+            | _ -> None)
+          l
+
+  let bool v =
+    match v with
+    | Atom "true" -> true
+    | Atom "false" -> false
+    | _ -> assert false
+
+  let mandatory f v =
+    match v with
+    | Some v -> f v
+    | None -> assert false
+end
+(*
+parse
+  (to_string
+     (List
+        [ List [ Atom "provides"; Atom "toto" ]
+        ; List [ Atom "requires"; Atom "foo"; Atom "bar"; Atom "foo\n bar" ]
+        ]))
+*)

compiler/lib/sexp.mli

@@ -0,0 +1,21 @@
+type t =
+  | Atom of string
+  | List of t list
+
+val to_string : t -> string
+
+val from_string : string -> t
+
+module Util : sig
+  val single : (t -> 'a) -> t list -> 'a
+
+  val mandatory : (t list -> 'a) -> t list option -> 'a
+
+  val string : t -> string
+
+  val bool : t -> bool
+
+  val assoc : t -> (string * t list) list
+
+  val member : string -> t -> t list option
+end

compiler/lib/unit_info.ml

@@ -150,3 +150,43 @@ let parse acc s =
       | Some ("Effects_without_cps", b) ->
           Some { acc with effects_without_cps = bool_of_string (String.trim b) }
       | Some (_, _) -> None)
+
+let to_sexp t =
+  let add nm skip v rem = if skip then rem else Sexp.List (Atom nm :: v) :: rem in
+  let set nm f rem =
+    add
+      nm
+      (List.equal ~eq:String.equal (f empty) (f t))
+      (List.map ~f:(fun x -> Sexp.Atom x) (f t))
+      rem
+  in
+  let bool nm f rem =
+    add
+      nm
+      (Bool.equal (f empty) (f t))
+      (if f t then [ Atom "true" ] else [ Atom "false" ])
+      rem
+  in
+  []
+  |> bool "effects_without_cps" (fun t -> t.effects_without_cps)
+  |> set "primitives" (fun t -> t.primitives)
+  |> bool "force_link" (fun t -> t.force_link)
+  |> set "requires" (fun t -> StringSet.elements t.requires)
+  |> add "provides" false [ Atom (StringSet.choose t.provides) ]
+
+let from_sexp t =
+  let open Sexp.Util in
+  let opt_list l = l |> Option.map ~f:(List.map ~f:string) in
+  let list default l = Option.value ~default (opt_list l) in
+  let set default l =
+    Option.value ~default (Option.map ~f:StringSet.of_list (opt_list l))
+  in
+  let bool default v = Option.value ~default (Option.map ~f:(single bool) v) in
+  { provides = t |> member "provides" |> mandatory (single string) |> StringSet.singleton
+  ; requires = t |> member "requires" |> set empty.requires
+  ; primitives = t |> member "primitives" |> list empty.primitives
+  ; force_link = t |> member "force_link" |> bool empty.force_link
+  ; effects_without_cps =
+      t |> member "effects_without_cps" |> bool empty.effects_without_cps
+  ; crcs = StringMap.empty
+  }

compiler/lib/unit_info.mli

@@ -41,3 +41,7 @@ val prefix : string
 val to_string : t -> string
 
 val parse : t -> string -> t option
+
+val to_sexp : t -> Sexp.t list
+
+val from_sexp : Sexp.t -> t