Skip to content

Commit

Permalink
Build_info/Unit_info: support for sexp serialization
Browse files Browse the repository at this point in the history
  • Loading branch information
vouillon authored and OlivierNicole committed Jul 30, 2024
1 parent 3204c33 commit ea7aec6
Show file tree
Hide file tree
Showing 6 changed files with 244 additions and 0 deletions.
14 changes: 14 additions & 0 deletions compiler/lib/build_info.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
4 changes: 4 additions & 0 deletions compiler/lib/build_info.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
161 changes: 161 additions & 0 deletions compiler/lib/sexp.ml
Original file line number Diff line number Diff line change
@@ -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" ]
]))
*)
21 changes: 21 additions & 0 deletions compiler/lib/sexp.mli
Original file line number Diff line number Diff line change
@@ -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
40 changes: 40 additions & 0 deletions compiler/lib/unit_info.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
}
4 changes: 4 additions & 0 deletions compiler/lib/unit_info.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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

0 comments on commit ea7aec6

Please sign in to comment.