Make sexp record parsing more composable
This commit is contained in:
Jeremie Dimino
parent
ee7ab05d9e
commit
7d10b0e983
|
|
@ -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
|
||||
|
|
|
|||
314
src/sexp.ml
314
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
|
||||
|
|
|
|||
24
src/sexp.mli
24
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
|
||||
|
|
|
|||
Loading…
Reference in New Issue