matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Make sexp record parsing more composable

This commit is contained in:
Jeremie Dimino 2017-02-23 18:31:33 +00:00
parent ee7ab05d9e
commit 7d10b0e983
3 changed files with 276 additions and 282 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

220
src/jbuild_types.ml
View File

@ -303,11 +303,10 @@ module Js_of_ocaml = struct
let t = let t =
record [ field "flags" (list string) ~default:[] record
; field "javascript_files" (list string) ~default:[] (field "flags" (list string) ~default:[] >>= fun flags ->
] field "javascript_files" (list string) ~default:[] >>= fun javascript_files ->
(fun flags javascript_files -> return { flags; javascript_files })
{ flags; javascript_files })
end end
module Lib_dep = struct module Lib_dep = struct
@ -416,83 +415,77 @@ module Library = struct
let t = let t =
record record
~ignore:["inline_tests"; "skip_from_default"; "lint"] (ignore_fields ["inline_tests"; "skip_from_default"; "lint"] >>= fun () ->
[ field "name" library_name field "name" library_name >>= fun name ->
; field_o "public_name" string field_o "public_name" string >>= fun public_name ->
; field_o "synopsis" string field_o "synopsis" string >>= fun synopsis ->
; field "install_c_headers" (list string) ~default:[] field "install_c_headers" (list string) ~default:[] >>= fun install_c_headers ->
; field "libraries" (list Lib_dep.t) ~default:[] field "libraries" (list Lib_dep.t) ~default:[] >>= fun libraries ->
; field "ppx_runtime_libraries" (list string) ~default:[] field "ppx_runtime_libraries" (list string) ~default:[] >>= fun ppx_runtime_libraries ->
; field_modules field_modules >>= fun modules ->
; field_oslu "c_flags" field_oslu "c_flags" >>= fun c_flags ->
; field_oslu "cxx_flags" field_oslu "cxx_flags" >>= fun cxx_flags ->
; field "c_names" (list string) ~default:[] field "c_names" (list string) ~default:[] >>= fun c_names ->
; field "cxx_names" (list string) ~default:[] field "cxx_names" (list string) ~default:[] >>= fun cxx_names ->
; field "library_flags" (list String_with_vars.t) ~default:[] field "library_flags" (list String_with_vars.t) ~default:[] >>= fun library_flags ->
; field "c_libraries" (list string) ~default:[] field "c_libraries" (list string) ~default:[] >>= fun c_libraries ->
; field_oslu "c_library_flags" field_oslu "c_library_flags" >>= fun c_library_flags ->
; field_pp "preprocess" field_pp "preprocess" >>= fun preprocess ->
; field "preprocessor_deps" (list Dep_conf.t) ~default:[] field "preprocessor_deps" (list Dep_conf.t) ~default:[] >>= fun preprocessor_deps ->
; field "self_build_stubs_archive" (option string) ~default:None field "self_build_stubs_archive" (option string) ~default:None >>= fun self_build_stubs_archive ->
; field_o "js_of_ocaml" Js_of_ocaml.t field_o "js_of_ocaml" Js_of_ocaml.t >>= fun js_of_ocaml ->
; field "virtual_deps" (list string) ~default:[] field "virtual_deps" (list string) ~default:[] >>= fun virtual_deps ->
; field "modes" (list Mode.t) ~default:Mode.all field "modes" (list Mode.t) ~default:Mode.all >>= fun modes ->
; field "includes" (list String_with_vars.t) ~default:[] field "includes" (list String_with_vars.t) ~default:[] >>= fun includes ->
; field "kind" Kind.t ~default:Kind.Normal field "kind" Kind.t ~default:Kind.Normal >>= fun kind ->
; field "wrapped" bool ~default:true field "wrapped" bool ~default:true >>= fun wrapped ->
; field_b "optional" field_b "optional" >>= fun optional ->
; field_osl "flags" field_osl "flags" >>= fun flags ->
; field_osl "ocamlc_flags" field_osl "ocamlc_flags" >>= fun ocamlc_flags ->
; field_osl "ocamlopt_flags" field_osl "ocamlopt_flags" >>= fun ocamlopt_flags ->
; field "extra_disabled_warnings" (list int) ~default:[] field "extra_disabled_warnings" (list int) ~default:[] >>= fun extra_disabled_warnings ->
] return
(fun name public_name synopsis install_c_headers libraries ppx_runtime_libraries { name
modules c_flags cxx_flags c_names cxx_names library_flags c_libraries ; public_name
c_library_flags preprocess ; synopsis
preprocessor_deps self_build_stubs_archive js_of_ocaml virtual_deps modes ; install_c_headers
includes kind wrapped optional flags ocamlc_flags ocamlopt_flags ; libraries
extra_disabled_warnings -> ; ppx_runtime_libraries
{ name ; modes
; public_name ; kind
; synopsis ; modules
; install_c_headers ; c_names
; libraries ; c_flags
; ppx_runtime_libraries ; cxx_names
; modes ; cxx_flags
; kind ; includes
; modules ; library_flags
; c_names ; c_library_flags =
; c_flags Ordered_set_lang.Unexpanded.append
; cxx_names (Ordered_set_lang.Unexpanded.t
; cxx_flags (Sexp.To_sexp.(list string (List.map c_libraries ~f:((^) "-l")))))
; includes c_library_flags
; library_flags ; preprocess
; c_library_flags = ; preprocessor_deps
Ordered_set_lang.Unexpanded.append ; self_build_stubs_archive
(Ordered_set_lang.Unexpanded.t ; js_of_ocaml
(Sexp.To_sexp.(list string (List.map c_libraries ~f:((^) "-l"))))) ; virtual_deps
c_library_flags ; wrapped
; preprocess ; optional
; preprocessor_deps ; flags =
; self_build_stubs_archive if Ordered_set_lang.is_standard flags && extra_disabled_warnings <> [] then
; js_of_ocaml Ordered_set_lang.append flags
; virtual_deps (Ordered_set_lang.t
; wrapped (List [ Atom "-w"
; optional ; Atom
; flags = (String.concat ~sep:""
if Ordered_set_lang.is_standard flags && extra_disabled_warnings <> [] then (List.map extra_disabled_warnings ~f:(sprintf "-%d")))
Ordered_set_lang.append flags ]))
(Ordered_set_lang.t else
(List [ Atom "-w" flags
; Atom ; ocamlc_flags
(String.concat ~sep:"" ; ocamlopt_flags
(List.map extra_disabled_warnings ~f:(sprintf "-%d"))) })
]))
else
flags
; ocamlc_flags
; ocamlopt_flags
})
let has_stubs t = let has_stubs t =
match t.c_names, t.cxx_names, t.self_build_stubs_archive with match t.c_names, t.cxx_names, t.self_build_stubs_archive with
@ -523,21 +516,21 @@ module Executables = struct
let t = let t =
record record
~ignore:["js_of_ocaml"; "only_shared_object"; "review_help"; "skip_from_default"] (ignore_fields
[ field "names" (list string) ["js_of_ocaml"; "only_shared_object"; "review_help"; "skip_from_default"]
; field_o "object_public_name" string >>= fun () ->
; field_o "synopsis" string field "names" (list string) >>= fun names ->
; field "link_executables" bool ~default:true field_o "object_public_name" string >>= fun object_public_name ->
; field "libraries" (list Lib_dep.t) ~default:[] field_o "synopsis" string >>= fun synopsis ->
; field "link_flags" (list string) ~default:[] field "link_executables" bool ~default:true >>= fun link_executables ->
; field_modules field "libraries" (list Lib_dep.t) >>= fun libraries ->
; field_pp "preprocess" field "link_flags" (list string) ~default:[] >>= fun link_flags ->
; field_osl "flags" field_modules >>= fun modules ->
; field_osl "ocamlc_flags" field_pp "preprocess" >>= fun preprocess ->
; field_osl "ocamlopt_flags" field_osl "flags" >>= fun flags ->
] field_osl "ocamlc_flags" >>= fun ocamlc_flags ->
(fun names object_public_name synopsis link_executables libraries link_flags modules field_osl "ocamlopt_flags" >>= fun ocamlopt_flags ->
preprocess flags ocamlc_flags ocamlopt_flags -> return
{ names { names
; object_public_name ; object_public_name
; synopsis ; synopsis
@ -560,13 +553,12 @@ module Rule = struct
} }
let t = let t =
record ~ignore:["sandbox"] record
[ field "targets" (list file_in_current_dir) (ignore_fields ["sandbox"] >>= fun () ->
; field "deps" (list Dep_conf.t) field "targets" (list file_in_current_dir) >>= fun targets ->
; field "action" User_action.Unexpanded.t field "deps" (list Dep_conf.t) >>= fun deps ->
] field "action" User_action.Unexpanded.t >>= fun action ->
(fun targets deps action -> return { targets; deps; action })
{ targets; deps; action })
end end
module Ocamllex = struct module Ocamllex = struct
@ -627,11 +619,10 @@ module Install_conf = struct
let t = let t =
record record
[ field "section" Install.Section.t (field "section" Install.Section.t >>= fun section ->
; field "files" (list file) field "files" (list file) >>= fun files ->
; field_o "package" string field_o "package" string >>= fun package ->
] return
(fun section files package ->
{ section { section
; files ; files
; package ; package
@ -646,11 +637,12 @@ module Alias_conf = struct
} }
let t = let t =
record ~ignore:["sandbox"] record
[ field "name" string (ignore_fields ["sandbox"] >>= fun () ->
; field "deps" (list Dep_conf.t) ~default:[] field "name" string >>= fun name ->
; field_o "action" User_action.Unexpanded.t ] field "deps" (list Dep_conf.t) ~default:[] >>= fun deps ->
(fun name deps action -> field_o "action" User_action.Unexpanded.t >>= fun action ->
return
{ name { name
; deps ; deps
; action ; action

314
src/sexp.ml
View File

@ -132,136 +132,124 @@ module Of_sexp = struct
| Error (key, _v1, _v2) -> | Error (key, _v1, _v2) ->
of_sexp_error (sprintf "key %S present multiple times" key) sexp of_sexp_error (sprintf "key %S present multiple times" key) sexp
module Field_spec = struct type unparsed_field =
type 'a kind = { value : sexp option
| Field : (sexp -> 'a) * 'a option -> 'a kind ; entry : sexp
| Field_o : (sexp -> 'a) -> 'a option kind }
| Field_b : bool kind
type 'a t = module Name_map = Map.Make(struct
{ name : string type t = string
; kind : 'a kind let compare a b =
let alen = String.length a and blen = String.length b in
if alen < blen then
-1
else if alen > blen then
1
else
String.compare a b
end)
type record_parser_state =
{ record : sexp
; unparsed : unparsed_field Name_map.t
; known : string list
}
type 'a record_parser = record_parser_state -> 'a * record_parser_state
let return x state = (x, state)
let (>>=) m f state =
let x, state = m state in
f x state
let consume name state =
{ state with
unparsed = Name_map.remove name state.unparsed
; known = name :: state.known
}
let add_known name state =
{ state with known = name :: state.known }
let ignore_fields names state =
let unparsed =
List.fold_left names ~init:state.unparsed ~f:(fun acc name ->
Name_map.remove name acc)
in
((),
{ state with
unparsed
; known = List.rev_append names state.known
})
let field name ?default value_of_sexp state =
match Name_map.find name state.unparsed with
| Some { value = Some value } ->
(value_of_sexp value, consume name state)
| Some { value = None } ->
of_sexp_error (Printf.sprintf "field %s needs a value" name) state.record
| None ->
match default with
| Some v -> (v, add_known name state)
| None ->
of_sexp_error (Printf.sprintf "field %s missing" name) state.record
let field_o name value_of_sexp state =
match Name_map.find name state.unparsed with
| Some { value = Some value } ->
(Some (value_of_sexp value), consume name state)
| Some { value = None } ->
of_sexp_error (Printf.sprintf "field %s needs a value" name) state.record
| None -> (None, add_known name state)
let field_b name state =
match Name_map.find name state.unparsed with
| Some { value = Some value } ->
(bool value, consume name state)
| Some { value = None } ->
(true, consume name state)
| None ->
(false, add_known name state)
let make_record_parser_state sexp =
match sexp with
| Atom _ -> of_sexp_error "List expected" sexp
| List sexps ->
let unparsed =
List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp ->
match sexp with
| List [Atom name] ->
Name_map.add acc ~key:name ~data:{ value = None; entry = sexp }
| List [name_sexp; value] -> begin
match name_sexp with
| Atom name ->
Name_map.add acc ~key:name ~data:{ value = Some value; entry = sexp }
| List _ ->
of_sexp_error "Atom expected" name_sexp
end
| _ ->
of_sexp_error "S-expression of the form (_ _) expected" sexp)
in
{ record = sexp
; known = []
; unparsed
} }
let field name ?default of_sexp = { name; kind = Field (of_sexp, default) } let record parse sexp =
let field_o name of_sexp = { name; kind = Field_o of_sexp } let state = make_record_parser_state sexp in
let field_b name = { name; kind = Field_b } let v, state = parse state in
end if Name_map.is_empty state.unparsed then
v
let field = Field_spec.field
let field_o = Field_spec.field_o
let field_b = Field_spec.field_b
module Fields_spec = struct
type ('a, 'b) t =
| [] : ('a, 'a) t
| ( :: ) : 'a Field_spec.t * ('b, 'c) t -> ('a -> 'b, 'c) t
let rec names : type a b. (a, b) t -> string list = function
| [] -> []
| { name; _ } :: t -> name :: names t
end
let compare_names a b =
let alen = String.length a and blen = String.length b in
if alen < blen then
-1
else if alen > blen then
1
else else
String.compare a b let name, { entry; _ } = Name_map.choose state.unparsed in
let name_sexp =
let binary_search = match entry with
let rec loop entries name a b = | List (s :: _) -> s
if a >= b then | _ -> assert false
None in
else of_sexp_error
let c = (a + b) lsr 1 in (Printf.sprintf "Unknown field %s%s" name
let name', position = entries.(c) in (hint name state.known)) name_sexp
let d = compare_names name name' in
if d < 0 then
loop entries name a c
else if d > 0 then
loop entries name (c + 1) b
else
Some position
in
fun entries name -> loop entries name 0 (Array.length entries)
type field_value =
| Unset
| Value of sexp
| Without_value
let parse_field field_names field_values sexp =
match sexp with
| List [name_sexp; value_sexp] -> begin
match name_sexp with
| List _ -> of_sexp_error "Atom expected" name_sexp
| Atom name ->
match binary_search field_names name with
| Some (-1) -> () (* ignored field *)
| Some n -> field_values.(n) <- Value value_sexp
| None -> of_sexp_error (Printf.sprintf "Unknown field %s" name) name_sexp
end
| List [Atom name] -> begin
match binary_search field_names name with
| Some (-1) -> () (* ignored field *)
| Some n -> field_values.(n) <- Without_value
| None -> of_sexp_error (Printf.sprintf "Unknown field %s" name) sexp
end
| _ ->
of_sexp_error "S-expression of the form (_ _) expected" sexp
let rec parse_fields field_names field_values sexps =
match sexps with
| [] -> ()
| sexp :: sexps ->
parse_field field_names field_values sexp;
parse_fields field_names field_values sexps
let parse_field_value : type a. sexp -> a Field_spec.t -> field_value -> a =
fun full_sexp spec value ->
let open Field_spec in
let { name; kind } = spec in
match kind, value with
| Field (_, None), Unset ->
of_sexp_error (Printf.sprintf "field %s missing" name) full_sexp
| Field (_, Some default), Unset -> default
| Field (f, _), Value sexp -> f sexp
| Field_o _, Unset -> None
| Field_o f, Value sexp -> Some (f sexp)
| Field_b, Unset -> false
| Field_b, Without_value -> true
| Field_b, Value sexp -> bool sexp
| _, Without_value ->
of_sexp_error (Printf.sprintf "field %s needs a value" name) full_sexp
let rec parse_field_values
: type a b. sexp -> (a, b) Fields_spec.t -> a -> field_value array -> int -> b =
fun full_sexp spec k values n ->
let open Fields_spec in
match spec with
| [] -> k
| field_spec :: spec ->
let v = parse_field_value full_sexp field_spec values.(n) in
parse_field_values full_sexp spec (k v) values (n + 1)
let record ?(ignore=[]) spec =
let names =
Fields_spec.names spec
|> List.mapi ~f:(fun i name -> (name, i))
|> List.rev_append (List.rev_map ignore ~f:(fun n -> (n, -1)))
|> List.sort ~cmp:(fun (a, _) (b, _) -> compare_names a b)
|> Array.of_list
in
fun record_of_fields sexp ->
match sexp with
| Atom _ -> of_sexp_error "List expected" sexp
| List sexps ->
let field_values = Array.make (Array.length names) Unset in
parse_fields names field_values sexps;
parse_field_values sexp spec record_of_fields field_values 0
module Constructor_args_spec = struct module Constructor_args_spec = struct
type 'a conv = 'a t type 'a conv = 'a t
@ -292,34 +280,54 @@ module Of_sexp = struct
let cstr name args make = let cstr name args make =
Constructor_spec.T { name; args; make } Constructor_spec.T { name; args; make }
let find_cstr names sexp s = let equal_cstr_name a b =
match binary_search names s with let alen = String.length a and blen = String.length b in
| Some cstr -> cstr if alen <> blen then
| None -> of_sexp_error (sprintf "Unknown constructor %s" s) sexp false
else if alen = 0 then
true
else
let is_cap s =
match s.[0] with
| 'A'..'Z' -> true
| _ -> false
in
match is_cap a, is_cap b with
| true, true | false, false ->
a = b
| true, false ->
a = String.capitalize_ascii b
| false, true ->
String.capitalize_ascii a = b
let sum cstrs = let find_cstr cstrs sexp name =
let names = match
List.concat_map cstrs ~f:(fun cstr -> List.find cstrs ~f:(fun (Constructor_spec.T cstr) ->
let name = Constructor_spec.name cstr in equal_cstr_name cstr.name name)
[ String.capitalize_ascii name, cstr with
; String.uncapitalize_ascii name, cstr | Some cstr -> cstr
]) | None ->
|> List.sort ~cmp:(fun (a, _) (b, _) -> compare_names a b) of_sexp_error
|> Array.of_list (sprintf "Unknown constructor %s%s" name
in (hint
fun sexp -> (String.uncapitalize_ascii name)
match sexp with (List.map cstrs ~f:(fun (Constructor_spec.T c) ->
| Atom s -> begin String.uncapitalize_ascii c.name)))
let (Constructor_spec.T c) = find_cstr names sexp s in ) sexp
Constructor_args_spec.convert c.args sexp [] c.make
end let sum cstrs sexp =
| List [] -> of_sexp_error "non-empty list expected" sexp match sexp with
| List (name_sexp :: args) -> | Atom s -> begin
match name_sexp with let (Constructor_spec.T c) = find_cstr cstrs sexp s in
| List _ -> of_sexp_error "Atom expected" name_sexp Constructor_args_spec.convert c.args sexp [] c.make
| Atom s -> end
let (Constructor_spec.T c) = find_cstr names sexp s in | List [] -> of_sexp_error "non-empty list expected" sexp
Constructor_args_spec.convert c.args sexp args c.make | List (name_sexp :: args) ->
match name_sexp with
| List _ -> of_sexp_error "Atom expected" name_sexp
| Atom s ->
let (Constructor_spec.T c) = find_cstr cstrs sexp s in
Constructor_args_spec.convert c.args sexp args c.make
end end
(* (*
module Both = struct module Both = struct

24
src/sexp.mli
View File

@ -39,24 +39,18 @@ module To_sexp : Combinators with type 'a t = 'a -> t
module Of_sexp : sig module Of_sexp : sig
include Combinators with type 'a t = t -> 'a include Combinators with type 'a t = t -> 'a
module Field_spec : sig (* Record parsing monad *)
type 'a t type 'a record_parser
end val return : 'a -> 'a record_parser
val ( >>= ) : 'a record_parser -> ('a -> 'b record_parser) -> 'b record_parser
module Fields_spec : sig val field : string -> ?default:'a -> 'a t -> 'a record_parser
type ('a, 'b) t = val field_o : string -> 'a t -> 'a option record_parser
| [] : ('a, 'a) t val field_b : string -> bool record_parser
| ( :: ) : 'a Field_spec.t * ('b, 'c) t -> ('a -> 'b, 'c) t
end
val field : string -> ?default:'a -> 'a t -> 'a Field_spec.t val ignore_fields : string list -> unit record_parser
val field_o : string -> 'a t -> 'a option Field_spec.t
val field_b : string -> bool Field_spec.t
val record val record : 'a record_parser -> 'a t
: ?ignore:string list
-> ('record_of_fields, 'record) Fields_spec.t
-> 'record_of_fields -> 'record t
module Constructor_spec : sig module Constructor_spec : sig
type 'a t type 'a t