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

Refactor Sexp.of_sexp_error API

This commit is contained in:
Jeremie Dimino 2017-02-24 10:49:27 +00:00
parent 942754495e
commit 0f28c8bba0
5 changed files with 57 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/jbuild_load.ml
View File

@ -23,7 +23,7 @@ let load ~dir ~visible_packages ~version =
| [] -> version
| [(v, _)] -> v
| _ :: (_, sexp) :: _ ->
of_sexp_error "jbuilder_version specified too many times" sexp
of_sexp_error sexp "jbuilder_version specified too many times"
in
(version, List.filter_map sexps ~f:(Stanza.select version)))
in

31
src/jbuild_types.ml
View File

@ -10,6 +10,7 @@ open Sexp.Of_sexp
type sexp = Sexp.t = Atom of string | List of sexp list
let of_sexp_error = Sexp.of_sexp_error
let of_sexp_errorf = Sexp.of_sexp_errorf
module Jbuilder_version = struct
type t =
@ -26,7 +27,7 @@ module Jbuilder_version = struct
end
let invalid_module_name sexp =
of_sexp_error "invalid module name" sexp
of_sexp_error sexp "invalid module name"
let module_name sexp =
match string sexp with
@ -41,7 +42,7 @@ let module_name sexp =
let module_names sexp = String_set.of_list (list module_name sexp)
let invalid_lib_name sexp =
of_sexp_error "invalid library name" sexp
of_sexp_error sexp "invalid library name"
let library_name sexp =
match string sexp with
@ -56,16 +57,16 @@ let library_name sexp =
let file sexp =
match string sexp with
| "." | ".." ->
Sexp.of_sexp_error "'.' and '..' are not valid filenames" sexp
of_sexp_error sexp "'.' and '..' are not valid filenames"
| fn -> fn
let file_in_current_dir sexp =
match string sexp with
| "." | ".." ->
Sexp.of_sexp_error "'.' and '..' are not valid filenames" sexp
of_sexp_error sexp "'.' and '..' are not valid filenames"
| fn ->
if Filename.dirname fn <> Filename.current_dir_name then
Sexp.of_sexp_error "file in current directory expected" sexp;
of_sexp_error sexp "file in current directory expected";
fn
module Raw_string () : sig
@ -92,7 +93,7 @@ module Pp = struct
let t sexp =
let s = string sexp in
if String.is_prefix s ~prefix:"-" then
of_sexp_error "flag not allowed here" sexp
of_sexp_error sexp "flag not allowed here"
else
of_string s
@ -133,13 +134,13 @@ module User_action = struct
| List [ Atom "chdir"; dir; arg ] -> Chdir (a dir, t a arg)
| List [ Atom "setenv"; var; value; arg ] -> Setenv (a var, a value, t a arg)
| _ ->
of_sexp_error "\
of_sexp_error sexp "\
invalid action, expected one of:
(run <prog> <args>)
(chdir <dir> <action>)
(setenv <var> <value> <action>)
" sexp
"
let rec map t ~f =
match t with
@ -292,7 +293,7 @@ module Preprocess_map = struct
|> function
| Ok map -> Per_file map
| Error (name, _, _) ->
Sexp.of_sexp_error (sprintf "module %s present in two different sets" name) sexp
of_sexp_error sexp (sprintf "module %s present in two different sets" name)
end
| sexp -> For_all (Preprocess.t sexp)
@ -343,7 +344,7 @@ module Lib_dep = struct
; file = file sexp
}
| Atom "->" :: _ | List _ :: _ | [] ->
of_sexp_error "(<[!]libraries>... -> <file>) expected" sexp
of_sexp_error sexp "(<[!]libraries>... -> <file>) expected"
| Atom s :: l ->
let len = String.length s in
if len > 0 && s.[0] = '!' then
@ -353,7 +354,7 @@ module Lib_dep = struct
loop (Pos s :: acc) l
in
loop [] l
| sexp -> of_sexp_error "(<library-name> <code>) expected" sexp
| sexp -> of_sexp_error sexp "(<library-name> <code>) expected"
let sexp_of_choice { lits; file } =
List (List.fold_right lits ~init:[Atom "->"; Atom file] ~f:(fun lit acc ->
@ -369,8 +370,7 @@ module Lib_dep = struct
; choices = List.map libs ~f:choice
}
| sexp ->
of_sexp_error "<library> or (select <module> from <libraries...>) expected"
sexp
of_sexp_error sexp "<library> or (select <module> from <libraries...>) expected"
let to_lib_names = function
| Direct s -> [s]
@ -688,7 +688,7 @@ module Provides = struct
; file
}
| sexp ->
of_sexp_error "[<name>] or [<name> (file <file>)] expected" sexp
of_sexp_error sexp "[<name>] or [<name> (file <file>)] expected"
let vjs = v1
end
@ -704,9 +704,8 @@ module Install_conf = struct
| Atom src -> { src; dst = None }
| List [Atom src; Atom "as"; Atom dst] -> { src; dst = Some dst }
| _ ->
of_sexp_error
of_sexp_error sexp
"invalid format, <name> or (<name> as <install-as>) expected"
sexp
type t =
{ section : Install.Section.t

74
src/sexp.ml
View File

@ -39,9 +39,10 @@ let locate_in_list ts ~sub ~locs =
let locate t ~sub ~locs =
locate_in_list [t] ~sub ~locs:[locs]
exception Of_sexp_error of string * t
exception Of_sexp_error of t * string
let of_sexp_error msg t = raise (Of_sexp_error (msg, t))
let of_sexp_error t msg = raise (Of_sexp_error (t, msg))
let of_sexp_errorf t fmt = Printf.ksprintf (of_sexp_error t) fmt
let must_escape str =
let len = String.length str in
@ -93,44 +94,44 @@ module Of_sexp = struct
let unit = function
| List [] -> ()
| sexp -> of_sexp_error "() expected" sexp
| sexp -> of_sexp_error sexp "() expected"
let string = function
| Atom s -> s
| List _ as sexp -> of_sexp_error "Atom expected" sexp
| List _ as sexp -> of_sexp_error sexp "Atom expected"
let int sexp =
let s = string sexp in
try
int_of_string s
with _ ->
of_sexp_error "Integer expected" sexp
of_sexp_error sexp "Integer expected"
let bool sexp =
match string sexp with
| "true" -> true
| "false" -> false
| _ -> of_sexp_error "'true' or 'false' expected" sexp
| _ -> of_sexp_error sexp "'true' or 'false' expected"
let pair fa fb = function
| List [a; b] -> (fa a, fb b)
| sexp -> of_sexp_error "S-expression of the form (_ _) expected" sexp
| sexp -> of_sexp_error sexp "S-expression of the form (_ _) expected"
let list f = function
| Atom _ as sexp -> of_sexp_error "List expected" sexp
| Atom _ as sexp -> of_sexp_error sexp "List expected"
| List l -> List.map l ~f
let option f = function
| List [] -> None
| List [x] -> Some (f x)
| sexp -> of_sexp_error "S-expression of the form () or (_) expected" sexp
| sexp -> of_sexp_error sexp "S-expression of the form () or (_) expected"
let string_set sexp = String_set.of_list (list string sexp)
let string_map f sexp =
match String_map.of_alist (list (pair string f) sexp) with
| Ok x -> x
| Error (key, _v1, _v2) ->
of_sexp_error (sprintf "key %S present multiple times" key) sexp
of_sexp_error sexp (sprintf "key %S present multiple times" key)
type unparsed_field =
{ value : sexp option
@ -187,19 +188,19 @@ module Of_sexp = struct
| 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
of_sexp_error state.record (Printf.sprintf "field %s needs a value" name)
| None ->
match default with
| Some v -> (v, add_known name state)
| None ->
of_sexp_error (Printf.sprintf "field %s missing" name) state.record
of_sexp_error state.record (Printf.sprintf "field %s missing" name)
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
of_sexp_error state.record (Printf.sprintf "field %s needs a value" name)
| None -> (None, add_known name state)
let field_b name state =
@ -213,7 +214,7 @@ module Of_sexp = struct
let make_record_parser_state sexp =
match sexp with
| Atom _ -> of_sexp_error "List expected" sexp
| Atom _ -> of_sexp_error sexp "List expected"
| List sexps ->
let unparsed =
List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp ->
@ -225,10 +226,10 @@ module Of_sexp = struct
| Atom name ->
Name_map.add acc ~key:name ~data:{ value = Some value; entry = sexp }
| List _ ->
of_sexp_error "Atom expected" name_sexp
of_sexp_error name_sexp "Atom expected"
end
| _ ->
of_sexp_error "S-expression of the form (_ _) expected" sexp)
of_sexp_error sexp "S-expression of the form (_ _) expected")
in
{ record = sexp
; known = []
@ -247,9 +248,8 @@ module Of_sexp = struct
| List (s :: _) -> s
| _ -> assert false
in
of_sexp_error
(Printf.sprintf "Unknown field %s%s" name
(hint name state.known)) name_sexp
of_sexp_errorf name_sexp
"Unknown field %s%s" name (hint name state.known)
module Constructor_args_spec = struct
type 'a conv = 'a t
@ -261,8 +261,8 @@ module Of_sexp = struct
= fun t sexp sexps f ->
match t, sexps with
| [], [] -> f
| _ :: _, [] -> of_sexp_error "not enough arguments" sexp
| [], _ :: _ -> of_sexp_error "too many arguments" sexp
| _ :: _, [] -> of_sexp_error sexp "not enough arguments"
| [], _ :: _ -> of_sexp_error sexp "too many arguments"
| conv :: t, s :: sexps ->
convert t sexp sexps (f (conv s))
end
@ -307,13 +307,12 @@ module Of_sexp = struct
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
of_sexp_errorf sexp
"Unknown constructor %s%s" name
(hint
(String.uncapitalize_ascii name)
(List.map cstrs ~f:(fun (Constructor_spec.T c) ->
String.uncapitalize_ascii c.name)))
let sum cstrs sexp =
match sexp with
@ -321,17 +320,17 @@ module Of_sexp = struct
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 [] -> of_sexp_error sexp "non-empty list expected"
| List (name_sexp :: args) ->
match name_sexp with
| List _ -> of_sexp_error "Atom expected" name_sexp
| List _ -> of_sexp_error name_sexp "Atom expected"
| Atom s ->
let (Constructor_spec.T c) = find_cstr cstrs sexp s in
Constructor_args_spec.convert c.args sexp args c.make
let enum cstrs sexp =
match sexp with
| List _ -> of_sexp_error "Atom expected" sexp
| List _ -> of_sexp_error sexp "Atom expected"
| Atom s ->
match
List.find cstrs ~f:(fun (name, _) ->
@ -339,13 +338,12 @@ module Of_sexp = struct
with
| Some (_, value) -> value
| None ->
of_sexp_error
(sprintf "Unknown value %s%s" s
(hint
(String.uncapitalize_ascii s)
(List.map cstrs ~f:(fun (name, _) ->
String.uncapitalize_ascii name)))
) sexp
of_sexp_errorf sexp
"Unknown value %s%s" s
(hint
(String.uncapitalize_ascii s)
(List.map cstrs ~f:(fun (name, _) ->
String.uncapitalize_ascii name)))
end
(*
module Both = struct

5
src/sexp.mli
View File

@ -4,9 +4,10 @@ type t =
| Atom of string
| List of t list
exception Of_sexp_error of string * t
exception Of_sexp_error of t * string
val of_sexp_error : string -> t -> _
val of_sexp_error : t -> string -> _
val of_sexp_errorf : t -> ('a, unit, string, 'b) format4 -> 'a
module Locs : sig
type t =

4
src/sexp_load.ml
View File

@ -6,7 +6,7 @@ let single fn f =
in
try
f sexp
with Sexp.Of_sexp_error (msg, sub) ->
with Sexp.Of_sexp_error (sub, msg) ->
let loc =
match Sexp.locate sexp ~sub ~locs with
| None -> Loc.in_file fn
@ -21,7 +21,7 @@ let many fn f =
in
try
f sexps
with Sexp.Of_sexp_error (msg, sub) ->
with Sexp.Of_sexp_error (sub, msg) ->
let loc =
match Sexp.locate_in_list sexps ~sub ~locs with
| None -> Loc.in_file fn