From 7d10b0e983cf4baaa42e545ea9f61bf02b95b807 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Thu, 23 Feb 2017 18:31:33 +0000 Subject: [PATCH] Make sexp record parsing more composable --- src/jbuild_types.ml | 220 +++++++++++++++---------------- src/sexp.ml | 314 +++++++++++++++++++++++--------------------- src/sexp.mli | 24 ++-- 3 files changed, 276 insertions(+), 282 deletions(-) diff --git a/src/jbuild_types.ml b/src/jbuild_types.ml index 9910d29e..0957730c 100644 --- a/src/jbuild_types.ml +++ b/src/jbuild_types.ml @@ -303,11 +303,10 @@ module Js_of_ocaml = struct let t = - record [ field "flags" (list string) ~default:[] - ; field "javascript_files" (list string) ~default:[] - ] - (fun flags javascript_files -> - { flags; javascript_files }) + record + (field "flags" (list string) ~default:[] >>= fun flags -> + field "javascript_files" (list string) ~default:[] >>= fun javascript_files -> + return { flags; javascript_files }) end module Lib_dep = struct @@ -416,83 +415,77 @@ module Library = struct let t = record - ~ignore:["inline_tests"; "skip_from_default"; "lint"] - [ field "name" library_name - ; field_o "public_name" string - ; field_o "synopsis" string - ; field "install_c_headers" (list string) ~default:[] - ; field "libraries" (list Lib_dep.t) ~default:[] - ; field "ppx_runtime_libraries" (list string) ~default:[] - ; field_modules - ; field_oslu "c_flags" - ; field_oslu "cxx_flags" - ; field "c_names" (list string) ~default:[] - ; field "cxx_names" (list string) ~default:[] - ; field "library_flags" (list String_with_vars.t) ~default:[] - ; field "c_libraries" (list string) ~default:[] - ; field_oslu "c_library_flags" - ; field_pp "preprocess" - ; field "preprocessor_deps" (list Dep_conf.t) ~default:[] - ; field "self_build_stubs_archive" (option string) ~default:None - ; field_o "js_of_ocaml" Js_of_ocaml.t - ; field "virtual_deps" (list string) ~default:[] - ; field "modes" (list Mode.t) ~default:Mode.all - ; field "includes" (list String_with_vars.t) ~default:[] - ; field "kind" Kind.t ~default:Kind.Normal - ; field "wrapped" bool ~default:true - ; field_b "optional" - ; field_osl "flags" - ; field_osl "ocamlc_flags" - ; field_osl "ocamlopt_flags" - ; field "extra_disabled_warnings" (list int) ~default:[] - ] - (fun name public_name synopsis install_c_headers libraries ppx_runtime_libraries - modules c_flags cxx_flags c_names cxx_names library_flags c_libraries - c_library_flags preprocess - preprocessor_deps self_build_stubs_archive js_of_ocaml virtual_deps modes - includes kind wrapped optional flags ocamlc_flags ocamlopt_flags - extra_disabled_warnings -> - { name - ; public_name - ; synopsis - ; install_c_headers - ; libraries - ; ppx_runtime_libraries - ; modes - ; kind - ; modules - ; c_names - ; c_flags - ; cxx_names - ; cxx_flags - ; includes - ; library_flags - ; c_library_flags = - Ordered_set_lang.Unexpanded.append - (Ordered_set_lang.Unexpanded.t - (Sexp.To_sexp.(list string (List.map c_libraries ~f:((^) "-l"))))) - c_library_flags - ; preprocess - ; preprocessor_deps - ; self_build_stubs_archive - ; js_of_ocaml - ; virtual_deps - ; wrapped - ; optional - ; flags = - if Ordered_set_lang.is_standard flags && extra_disabled_warnings <> [] then - Ordered_set_lang.append flags - (Ordered_set_lang.t - (List [ Atom "-w" - ; Atom - (String.concat ~sep:"" - (List.map extra_disabled_warnings ~f:(sprintf "-%d"))) - ])) - else - flags - ; ocamlc_flags - ; ocamlopt_flags - }) + (ignore_fields ["inline_tests"; "skip_from_default"; "lint"] >>= fun () -> + field "name" library_name >>= fun name -> + field_o "public_name" string >>= fun public_name -> + field_o "synopsis" string >>= fun synopsis -> + field "install_c_headers" (list string) ~default:[] >>= fun install_c_headers -> + field "libraries" (list Lib_dep.t) ~default:[] >>= fun libraries -> + field "ppx_runtime_libraries" (list string) ~default:[] >>= fun ppx_runtime_libraries -> + field_modules >>= fun modules -> + field_oslu "c_flags" >>= fun c_flags -> + field_oslu "cxx_flags" >>= fun cxx_flags -> + field "c_names" (list string) ~default:[] >>= fun c_names -> + field "cxx_names" (list string) ~default:[] >>= fun cxx_names -> + field "library_flags" (list String_with_vars.t) ~default:[] >>= fun library_flags -> + field "c_libraries" (list string) ~default:[] >>= fun c_libraries -> + field_oslu "c_library_flags" >>= fun c_library_flags -> + field_pp "preprocess" >>= fun preprocess -> + field "preprocessor_deps" (list Dep_conf.t) ~default:[] >>= fun preprocessor_deps -> + field "self_build_stubs_archive" (option string) ~default:None >>= fun self_build_stubs_archive -> + field_o "js_of_ocaml" Js_of_ocaml.t >>= fun js_of_ocaml -> + field "virtual_deps" (list string) ~default:[] >>= fun virtual_deps -> + field "modes" (list Mode.t) ~default:Mode.all >>= fun modes -> + field "includes" (list String_with_vars.t) ~default:[] >>= fun includes -> + field "kind" Kind.t ~default:Kind.Normal >>= fun kind -> + field "wrapped" bool ~default:true >>= fun wrapped -> + field_b "optional" >>= fun optional -> + field_osl "flags" >>= fun flags -> + field_osl "ocamlc_flags" >>= fun ocamlc_flags -> + field_osl "ocamlopt_flags" >>= fun ocamlopt_flags -> + field "extra_disabled_warnings" (list int) ~default:[] >>= fun extra_disabled_warnings -> + return + { name + ; public_name + ; synopsis + ; install_c_headers + ; libraries + ; ppx_runtime_libraries + ; modes + ; kind + ; modules + ; c_names + ; c_flags + ; cxx_names + ; cxx_flags + ; includes + ; library_flags + ; c_library_flags = + Ordered_set_lang.Unexpanded.append + (Ordered_set_lang.Unexpanded.t + (Sexp.To_sexp.(list string (List.map c_libraries ~f:((^) "-l"))))) + c_library_flags + ; preprocess + ; preprocessor_deps + ; self_build_stubs_archive + ; js_of_ocaml + ; virtual_deps + ; wrapped + ; optional + ; flags = + if Ordered_set_lang.is_standard flags && extra_disabled_warnings <> [] then + Ordered_set_lang.append flags + (Ordered_set_lang.t + (List [ Atom "-w" + ; Atom + (String.concat ~sep:"" + (List.map extra_disabled_warnings ~f:(sprintf "-%d"))) + ])) + else + flags + ; ocamlc_flags + ; ocamlopt_flags + }) let has_stubs t = match t.c_names, t.cxx_names, t.self_build_stubs_archive with @@ -523,21 +516,21 @@ module Executables = struct let t = record - ~ignore:["js_of_ocaml"; "only_shared_object"; "review_help"; "skip_from_default"] - [ field "names" (list string) - ; field_o "object_public_name" string - ; field_o "synopsis" string - ; field "link_executables" bool ~default:true - ; field "libraries" (list Lib_dep.t) ~default:[] - ; field "link_flags" (list string) ~default:[] - ; field_modules - ; field_pp "preprocess" - ; field_osl "flags" - ; field_osl "ocamlc_flags" - ; field_osl "ocamlopt_flags" - ] - (fun names object_public_name synopsis link_executables libraries link_flags modules - preprocess flags ocamlc_flags ocamlopt_flags -> + (ignore_fields + ["js_of_ocaml"; "only_shared_object"; "review_help"; "skip_from_default"] + >>= fun () -> + field "names" (list string) >>= fun names -> + field_o "object_public_name" string >>= fun object_public_name -> + field_o "synopsis" string >>= fun synopsis -> + field "link_executables" bool ~default:true >>= fun link_executables -> + field "libraries" (list Lib_dep.t) >>= fun libraries -> + field "link_flags" (list string) ~default:[] >>= fun link_flags -> + field_modules >>= fun modules -> + field_pp "preprocess" >>= fun preprocess -> + field_osl "flags" >>= fun flags -> + field_osl "ocamlc_flags" >>= fun ocamlc_flags -> + field_osl "ocamlopt_flags" >>= fun ocamlopt_flags -> + return { names ; object_public_name ; synopsis @@ -560,13 +553,12 @@ module Rule = struct } let t = - record ~ignore:["sandbox"] - [ field "targets" (list file_in_current_dir) - ; field "deps" (list Dep_conf.t) - ; field "action" User_action.Unexpanded.t - ] - (fun targets deps action -> - { targets; deps; action }) + record + (ignore_fields ["sandbox"] >>= fun () -> + field "targets" (list file_in_current_dir) >>= fun targets -> + field "deps" (list Dep_conf.t) >>= fun deps -> + field "action" User_action.Unexpanded.t >>= fun action -> + return { targets; deps; action }) end module Ocamllex = struct @@ -627,11 +619,10 @@ module Install_conf = struct let t = record - [ field "section" Install.Section.t - ; field "files" (list file) - ; field_o "package" string - ] - (fun section files package -> + (field "section" Install.Section.t >>= fun section -> + field "files" (list file) >>= fun files -> + field_o "package" string >>= fun package -> + return { section ; files ; package @@ -646,11 +637,12 @@ module Alias_conf = struct } let t = - record ~ignore:["sandbox"] - [ field "name" string - ; field "deps" (list Dep_conf.t) ~default:[] - ; field_o "action" User_action.Unexpanded.t ] - (fun name deps action -> + record + (ignore_fields ["sandbox"] >>= fun () -> + field "name" string >>= fun name -> + field "deps" (list Dep_conf.t) ~default:[] >>= fun deps -> + field_o "action" User_action.Unexpanded.t >>= fun action -> + return { name ; deps ; action diff --git a/src/sexp.ml b/src/sexp.ml index 0e838a95..a38d2541 100644 --- a/src/sexp.ml +++ b/src/sexp.ml @@ -132,136 +132,124 @@ module Of_sexp = struct | Error (key, _v1, _v2) -> of_sexp_error (sprintf "key %S present multiple times" key) sexp - module Field_spec = struct - type 'a kind = - | Field : (sexp -> 'a) * 'a option -> 'a kind - | Field_o : (sexp -> 'a) -> 'a option kind - | Field_b : bool kind + type unparsed_field = + { value : sexp option + ; entry : sexp + } - type 'a t = - { name : string - ; kind : 'a kind + module Name_map = Map.Make(struct + type t = string + 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 field_o name of_sexp = { name; kind = Field_o of_sexp } - let field_b name = { name; kind = Field_b } - end - - 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 + let record parse sexp = + let state = make_record_parser_state sexp in + let v, state = parse state in + if Name_map.is_empty state.unparsed then + v else - String.compare a b - - let binary_search = - let rec loop entries name a b = - if a >= b then - None - else - let c = (a + b) lsr 1 in - let name', position = entries.(c) in - 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 + let name, { entry; _ } = Name_map.choose state.unparsed in + let name_sexp = + match entry with + | List (s :: _) -> s + | _ -> assert false + in + of_sexp_error + (Printf.sprintf "Unknown field %s%s" name + (hint name state.known)) name_sexp module Constructor_args_spec = struct type 'a conv = 'a t @@ -292,34 +280,54 @@ module Of_sexp = struct let cstr name args make = Constructor_spec.T { name; args; make } - let find_cstr names sexp s = - match binary_search names s with - | Some cstr -> cstr - | None -> of_sexp_error (sprintf "Unknown constructor %s" s) sexp + let equal_cstr_name a b = + let alen = String.length a and blen = String.length b in + if alen <> blen then + 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 names = - List.concat_map cstrs ~f:(fun cstr -> - let name = Constructor_spec.name cstr in - [ String.capitalize_ascii name, cstr - ; String.uncapitalize_ascii name, cstr - ]) - |> List.sort ~cmp:(fun (a, _) (b, _) -> compare_names a b) - |> Array.of_list - in - fun sexp -> - match sexp with - | Atom s -> begin - let (Constructor_spec.T c) = find_cstr names sexp s in - Constructor_args_spec.convert c.args sexp [] c.make - end - | List [] -> of_sexp_error "non-empty list expected" sexp - | 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 names sexp s in - Constructor_args_spec.convert c.args sexp args c.make + let find_cstr cstrs sexp name = + match + List.find cstrs ~f:(fun (Constructor_spec.T cstr) -> + equal_cstr_name cstr.name name) + with + | Some cstr -> cstr + | None -> + of_sexp_error + (sprintf "Unknown constructor %s%s" name + (hint + (String.uncapitalize_ascii name) + (List.map cstrs ~f:(fun (Constructor_spec.T c) -> + String.uncapitalize_ascii c.name))) + ) sexp + + let sum cstrs sexp = + match sexp with + | Atom s -> begin + let (Constructor_spec.T c) = find_cstr cstrs sexp s in + Constructor_args_spec.convert c.args sexp [] c.make + end + | List [] -> of_sexp_error "non-empty list expected" sexp + | 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 (* module Both = struct diff --git a/src/sexp.mli b/src/sexp.mli index d12d732d..8ef2cdd6 100644 --- a/src/sexp.mli +++ b/src/sexp.mli @@ -39,24 +39,18 @@ module To_sexp : Combinators with type 'a t = 'a -> t module Of_sexp : sig include Combinators with type 'a t = t -> 'a - module Field_spec : sig - type 'a t - end + (* Record parsing monad *) + type 'a record_parser + val return : 'a -> 'a record_parser + val ( >>= ) : 'a record_parser -> ('a -> 'b record_parser) -> 'b record_parser - module Fields_spec : sig - type ('a, 'b) t = - | [] : ('a, 'a) t - | ( :: ) : 'a Field_spec.t * ('b, 'c) t -> ('a -> 'b, 'c) t - end + val field : string -> ?default:'a -> 'a t -> 'a record_parser + val field_o : string -> 'a t -> 'a option record_parser + val field_b : string -> bool record_parser - val field : string -> ?default:'a -> 'a t -> 'a Field_spec.t - val field_o : string -> 'a t -> 'a option Field_spec.t - val field_b : string -> bool Field_spec.t + val ignore_fields : string list -> unit record_parser - val record - : ?ignore:string list - -> ('record_of_fields, 'record) Fields_spec.t - -> 'record_of_fields -> 'record t + val record : 'a record_parser -> 'a t module Constructor_spec : sig type 'a t