Make Sexp.Of_sexp.t abstract
Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>
This commit is contained in:
parent
548bcad64c
commit
065e2bb26f
162
src/action.ml
162
src/action.ml
|
@ -21,78 +21,78 @@ module Make_ast
|
|||
struct
|
||||
include Ast
|
||||
|
||||
let rec t sexp =
|
||||
let t =
|
||||
let path = Path.t and string = String.t in
|
||||
sum
|
||||
[ "run",
|
||||
(next Program.t >>= fun prog ->
|
||||
rest string >>| fun args ->
|
||||
Run (prog, args))
|
||||
; "chdir",
|
||||
(next path >>= fun dn ->
|
||||
next t >>| fun t ->
|
||||
Chdir (dn, t))
|
||||
; "setenv",
|
||||
(next string >>= fun k ->
|
||||
next string >>= fun v ->
|
||||
next t >>| fun t ->
|
||||
Setenv (k, v, t))
|
||||
; "with-stdout-to",
|
||||
(next path >>= fun fn ->
|
||||
next t >>| fun t ->
|
||||
Redirect (Stdout, fn, t))
|
||||
; "with-stderr-to",
|
||||
(next path >>= fun fn ->
|
||||
next t >>| fun t ->
|
||||
Redirect (Stderr, fn, t))
|
||||
; "with-outputs-to",
|
||||
(next path >>= fun fn ->
|
||||
next t >>| fun t ->
|
||||
Redirect (Outputs, fn, t))
|
||||
; "ignore-stdout",
|
||||
(next t >>| fun t -> Ignore (Stdout, t))
|
||||
; "ignore-stderr",
|
||||
(next t >>| fun t -> Ignore (Stderr, t))
|
||||
; "ignore-outputs",
|
||||
(next t >>| fun t -> Ignore (Outputs, t))
|
||||
; "progn",
|
||||
(rest t >>| fun l -> Progn l)
|
||||
; "echo",
|
||||
(next string >>= fun x ->
|
||||
rest string >>| fun xs ->
|
||||
Echo (x :: xs))
|
||||
; "cat",
|
||||
(next path >>| fun x -> Cat x)
|
||||
; "copy",
|
||||
(next path >>= fun src ->
|
||||
next path >>| fun dst ->
|
||||
Copy (src, dst))
|
||||
; "copy#",
|
||||
(next path >>= fun src ->
|
||||
next path >>| fun dst ->
|
||||
Copy_and_add_line_directive (src, dst))
|
||||
; "copy-and-add-line-directive",
|
||||
(next path >>= fun src ->
|
||||
next path >>| fun dst ->
|
||||
Copy_and_add_line_directive (src, dst))
|
||||
; "system",
|
||||
(next string >>| fun cmd -> System cmd)
|
||||
; "bash",
|
||||
(next string >>| fun cmd -> Bash cmd)
|
||||
; "write-file",
|
||||
(next path >>= fun fn ->
|
||||
next string >>| fun s ->
|
||||
Write_file (fn, s))
|
||||
; "diff",
|
||||
(next path >>= fun file1 ->
|
||||
next path >>| fun file2 ->
|
||||
Diff { optional = false; file1; file2 })
|
||||
; "diff?",
|
||||
(next path >>= fun file1 ->
|
||||
next path >>| fun file2 ->
|
||||
Diff { optional = true; file1; file2 })
|
||||
]
|
||||
sexp
|
||||
Sexp.Of_sexp.fix (fun t ->
|
||||
sum
|
||||
[ "run",
|
||||
(next Program.t >>= fun prog ->
|
||||
rest string >>| fun args ->
|
||||
Run (prog, args))
|
||||
; "chdir",
|
||||
(next path >>= fun dn ->
|
||||
next t >>| fun t ->
|
||||
Chdir (dn, t))
|
||||
; "setenv",
|
||||
(next string >>= fun k ->
|
||||
next string >>= fun v ->
|
||||
next t >>| fun t ->
|
||||
Setenv (k, v, t))
|
||||
; "with-stdout-to",
|
||||
(next path >>= fun fn ->
|
||||
next t >>| fun t ->
|
||||
Redirect (Stdout, fn, t))
|
||||
; "with-stderr-to",
|
||||
(next path >>= fun fn ->
|
||||
next t >>| fun t ->
|
||||
Redirect (Stderr, fn, t))
|
||||
; "with-outputs-to",
|
||||
(next path >>= fun fn ->
|
||||
next t >>| fun t ->
|
||||
Redirect (Outputs, fn, t))
|
||||
; "ignore-stdout",
|
||||
(next t >>| fun t -> Ignore (Stdout, t))
|
||||
; "ignore-stderr",
|
||||
(next t >>| fun t -> Ignore (Stderr, t))
|
||||
; "ignore-outputs",
|
||||
(next t >>| fun t -> Ignore (Outputs, t))
|
||||
; "progn",
|
||||
(rest t >>| fun l -> Progn l)
|
||||
; "echo",
|
||||
(next string >>= fun x ->
|
||||
rest string >>| fun xs ->
|
||||
Echo (x :: xs))
|
||||
; "cat",
|
||||
(next path >>| fun x -> Cat x)
|
||||
; "copy",
|
||||
(next path >>= fun src ->
|
||||
next path >>| fun dst ->
|
||||
Copy (src, dst))
|
||||
; "copy#",
|
||||
(next path >>= fun src ->
|
||||
next path >>| fun dst ->
|
||||
Copy_and_add_line_directive (src, dst))
|
||||
; "copy-and-add-line-directive",
|
||||
(next path >>= fun src ->
|
||||
next path >>| fun dst ->
|
||||
Copy_and_add_line_directive (src, dst))
|
||||
; "system",
|
||||
(next string >>| fun cmd -> System cmd)
|
||||
; "bash",
|
||||
(next string >>| fun cmd -> Bash cmd)
|
||||
; "write-file",
|
||||
(next path >>= fun fn ->
|
||||
next string >>| fun s ->
|
||||
Write_file (fn, s))
|
||||
; "diff",
|
||||
(next path >>= fun file1 ->
|
||||
next path >>| fun file2 ->
|
||||
Diff { optional = false; file1; file2 })
|
||||
; "diff?",
|
||||
(next path >>= fun file1 ->
|
||||
next path >>| fun file2 ->
|
||||
Diff { optional = true; file1; file2 })
|
||||
])
|
||||
|
||||
let rec sexp_of_t : _ -> Sexp.t =
|
||||
let path = Path.sexp_of_t and string = String.sexp_of_t in
|
||||
|
@ -224,7 +224,7 @@ module Prog = struct
|
|||
|
||||
type t = (Path.t, Not_found.t) result
|
||||
|
||||
let t sexp = Ok (Path.t sexp)
|
||||
let t : t Sexp.Of_sexp.t = Sexp.Of_sexp.Parser.map ~f:Result.ok Path.t
|
||||
|
||||
let sexp_of_t = function
|
||||
| Ok s -> Path.sexp_of_t s
|
||||
|
@ -325,12 +325,11 @@ module Unexpanded = struct
|
|||
|
||||
include Make_ast(String_with_vars)(String_with_vars)(String_with_vars)(Uast)
|
||||
|
||||
let t sexp =
|
||||
match sexp with
|
||||
| Atom _ | Quoted_string _ ->
|
||||
let t = Sexp.Of_sexp.make (function
|
||||
| Atom _ | Quoted_string _ as sexp ->
|
||||
of_sexp_errorf sexp
|
||||
"if you meant for this to be executed with bash, write (bash \"...\") instead"
|
||||
| List _ -> t sexp
|
||||
| List _ as sexp -> Sexp.Of_sexp.parse t sexp)
|
||||
|
||||
let check_mkdir loc path =
|
||||
if not (Path.is_managed path) then
|
||||
|
@ -582,13 +581,14 @@ module Promotion = struct
|
|||
; dst : Path.t
|
||||
}
|
||||
|
||||
let t = function
|
||||
let t = Sexp.Of_sexp.make (function
|
||||
| Sexp.Ast.List (_, [src; Atom (_, A "as"); dst]) ->
|
||||
{ src = Path.t src
|
||||
; dst = Path.t dst
|
||||
let open Sexp.Of_sexp in
|
||||
{ src = parse Path.t src
|
||||
; dst = parse Path.t dst
|
||||
}
|
||||
| sexp ->
|
||||
Sexp.Of_sexp.of_sexp_errorf sexp "(<file> as <file>) expected"
|
||||
Sexp.Of_sexp.of_sexp_errorf sexp "(<file> as <file>) expected")
|
||||
|
||||
let sexp_of_t { src; dst } =
|
||||
Sexp.List [Path.sexp_of_t src; Sexp.unsafe_atom_of_string "as";
|
||||
|
@ -620,7 +620,7 @@ module Promotion = struct
|
|||
let load_db () =
|
||||
if Path.exists db_file then
|
||||
Io.Sexp.load db_file ~mode:Many
|
||||
|> List.map ~f:File.t
|
||||
|> List.map ~f:(Sexp.Of_sexp.parse File.t)
|
||||
else
|
||||
[]
|
||||
|
||||
|
|
|
@ -19,7 +19,7 @@ module Promoted_to_delete = struct
|
|||
let load () =
|
||||
if Path.exists fn then
|
||||
Io.Sexp.load fn ~mode:Many
|
||||
|> List.map ~f:Path.t
|
||||
|> List.map ~f:(Sexp.Of_sexp.parse Path.t)
|
||||
else
|
||||
[]
|
||||
|
||||
|
@ -1220,7 +1220,7 @@ let update_universe t =
|
|||
Utils.Cached_digest.remove universe_file;
|
||||
let n =
|
||||
if Path.exists universe_file then
|
||||
Sexp.Of_sexp.int (Io.Sexp.load ~mode:Single universe_file) + 1
|
||||
Sexp.Of_sexp.(parse int) (Io.Sexp.load ~mode:Single universe_file) + 1
|
||||
else
|
||||
0
|
||||
in
|
||||
|
|
|
@ -62,10 +62,11 @@ module Concurrency = struct
|
|||
else
|
||||
error
|
||||
|
||||
let t sexp =
|
||||
match of_string (string sexp) with
|
||||
| Ok t -> t
|
||||
| Error msg -> of_sexp_error sexp msg
|
||||
let t =
|
||||
Parser.map_validate string ~f:(fun s ->
|
||||
match of_string s with
|
||||
| Error m -> Sexp.Of_sexp.Parser.error m
|
||||
| Ok _ as s -> s)
|
||||
|
||||
let to_string = function
|
||||
| Auto -> "auto"
|
||||
|
@ -114,7 +115,7 @@ let user_config_file =
|
|||
"dune/config"
|
||||
|
||||
let load_config_file p =
|
||||
t (Io.Sexp.load p ~mode:Many_as_one)
|
||||
(Sexp.Of_sexp.parse t) (Io.Sexp.load p ~mode:Many_as_one)
|
||||
|
||||
let load_user_config_file () =
|
||||
if Path.exists user_config_file then
|
||||
|
|
|
@ -425,7 +425,7 @@ let create_for_opam ?root ~env ~targets ~profile ~switch ~name
|
|||
>>= fun s ->
|
||||
let vars =
|
||||
Usexp.parse_string ~fname:"<opam output>" ~mode:Single s
|
||||
|> Sexp.Of_sexp.(list (pair string string))
|
||||
|> Sexp.Of_sexp.(parse (list (pair string string)))
|
||||
|> Env.Map.of_list_multi
|
||||
|> Env.Map.mapi ~f:(fun var values ->
|
||||
match List.rev values with
|
||||
|
|
|
@ -70,12 +70,12 @@ end = struct
|
|||
else
|
||||
None
|
||||
|
||||
let named_of_sexp sexp =
|
||||
let s = string sexp in
|
||||
if validate s then
|
||||
Named s
|
||||
else
|
||||
of_sexp_error sexp "invalid project name"
|
||||
let named_of_sexp =
|
||||
Sexp.Of_sexp.Parser.map_validate string ~f:(fun s ->
|
||||
if validate s then
|
||||
Ok (Named s)
|
||||
else
|
||||
Sexp.Of_sexp.Parser.error "invalid project name")
|
||||
|
||||
let encode = function
|
||||
| Named s -> s
|
||||
|
@ -142,7 +142,9 @@ module Lang = struct
|
|||
; version = (ver_loc, ver)
|
||||
} = first_line
|
||||
in
|
||||
let ver = Syntax.Version.t (Atom (ver_loc, Sexp.Atom.of_string ver)) in
|
||||
let ver =
|
||||
Sexp.Of_sexp.parse Syntax.Version.t
|
||||
(Atom (ver_loc, Sexp.Atom.of_string ver)) in
|
||||
match Hashtbl.find langs name with
|
||||
| None ->
|
||||
Loc.fail name_loc "Unknown language %S.%s" name
|
||||
|
@ -196,7 +198,7 @@ let anonymous = lazy(
|
|||
; packages = Package.Name.Map.empty
|
||||
; root = get_local_path Path.root
|
||||
; version = None
|
||||
; stanza_parser = (fun _ -> assert false)
|
||||
; stanza_parser = Sexp.Of_sexp.make (fun _ -> assert false)
|
||||
; project_file = None
|
||||
}
|
||||
in
|
||||
|
@ -237,7 +239,7 @@ let parse ~dir ~lang_stanzas ~packages ~file =
|
|||
; root = get_local_path dir
|
||||
; version
|
||||
; packages
|
||||
; stanza_parser = (fun _ -> assert false)
|
||||
; stanza_parser = Sexp.Of_sexp.make (fun _ -> assert false)
|
||||
; project_file = Some file
|
||||
}
|
||||
in
|
||||
|
@ -263,7 +265,7 @@ let load_dune_project ~dir packages =
|
|||
Io.with_lexbuf_from_file fname ~f:(fun lb ->
|
||||
let lang_stanzas = Lang.parse (Dune_lexer.first_line lb) in
|
||||
let sexp = Sexp.Parser.parse lb ~mode:Many_as_one in
|
||||
parse ~dir ~lang_stanzas ~packages ~file:fname sexp)
|
||||
Sexp.Of_sexp.parse (parse ~dir ~lang_stanzas ~packages ~file:fname) sexp)
|
||||
|
||||
let make_jbuilder_project ~dir packages =
|
||||
let t =
|
||||
|
@ -272,7 +274,7 @@ let make_jbuilder_project ~dir packages =
|
|||
; root = get_local_path dir
|
||||
; version = None
|
||||
; packages
|
||||
; stanza_parser = (fun _ -> assert false)
|
||||
; stanza_parser = Sexp.Of_sexp.make (fun _ -> assert false)
|
||||
; project_file = None
|
||||
}
|
||||
in
|
||||
|
|
|
@ -40,16 +40,16 @@ module Dune_file = struct
|
|||
let extract_ignored_subdirs =
|
||||
let stanza =
|
||||
let open Sexp.Of_sexp in
|
||||
let sub_dir sexp =
|
||||
let dn = string sexp in
|
||||
if Filename.dirname dn <> Filename.current_dir_name ||
|
||||
match string sexp with
|
||||
| "" | "." | ".." -> true
|
||||
| _ -> false
|
||||
then
|
||||
of_sexp_errorf sexp "Invalid sub-directory name %S" dn
|
||||
else
|
||||
dn
|
||||
let sub_dir =
|
||||
Parser.map_validate string ~f:(fun dn ->
|
||||
if Filename.dirname dn <> Filename.current_dir_name ||
|
||||
match dn with
|
||||
| "" | "." | ".." -> true
|
||||
| _ -> false
|
||||
then
|
||||
Parser.errorf "Invalid sub-directory name %S" dn
|
||||
else
|
||||
Ok dn)
|
||||
in
|
||||
sum
|
||||
[ "ignored_subdirs", next (list sub_dir) >>| String.Set.of_list
|
||||
|
@ -60,7 +60,7 @@ module Dune_file = struct
|
|||
List.partition_map sexps ~f:(fun sexp ->
|
||||
match (sexp : Sexp.Ast.t) with
|
||||
| List (_, (Atom (_, A "ignored_subdirs") :: _)) ->
|
||||
Left (stanza sexp)
|
||||
Left (Sexp.Of_sexp.parse stanza sexp)
|
||||
| _ -> Right sexp)
|
||||
in
|
||||
let ignored_subdirs =
|
||||
|
|
|
@ -3,7 +3,7 @@ open Import
|
|||
let parse_sub_systems sexps =
|
||||
List.filter_map sexps ~f:(fun sexp ->
|
||||
let name, ver, data =
|
||||
Sexp.Of_sexp.(triple string (located Syntax.Version.t) raw) sexp
|
||||
Sexp.Of_sexp.(parse (triple string (located Syntax.Version.t) raw)) sexp
|
||||
in
|
||||
match Sub_system_name.get name with
|
||||
| None ->
|
||||
|
@ -24,15 +24,14 @@ let parse_sub_systems sexps =
|
|||
Syntax.Versioned_parser.find_exn M.parsers ~loc:vloc
|
||||
~data_version:ver
|
||||
in
|
||||
M.T (parser.parse data))
|
||||
M.T (Sexp.Of_sexp.parse parser.parse data))
|
||||
|
||||
let of_sexp =
|
||||
let open Sexp.Of_sexp in
|
||||
let version sexp =
|
||||
match string sexp with
|
||||
| "1" -> ()
|
||||
| _ ->
|
||||
of_sexp_error sexp "Unsupported version, only version 1 is supported"
|
||||
let version =
|
||||
Parser.map_validate string ~f:(function
|
||||
| "1" -> Ok ()
|
||||
| _ -> Parser.error "Unsupported version, only version 1 is supported")
|
||||
in
|
||||
sum
|
||||
[ "dune",
|
||||
|
@ -41,7 +40,7 @@ let of_sexp =
|
|||
parse_sub_systems l)
|
||||
]
|
||||
|
||||
let load fname = of_sexp (Io.Sexp.load ~mode:Single fname)
|
||||
let load fname = Sexp.Of_sexp.parse of_sexp (Io.Sexp.load ~mode:Single fname)
|
||||
|
||||
let gen confs =
|
||||
let sexps =
|
||||
|
|
328
src/jbuild.ml
328
src/jbuild.ml
|
@ -20,71 +20,78 @@ module Jbuild_version = struct
|
|||
let latest_stable = V1
|
||||
end
|
||||
|
||||
let invalid_module_name name sexp =
|
||||
of_sexp_error sexp (sprintf "invalid module name: %S" name)
|
||||
let invalid_module_name =
|
||||
Parser.errorf "invalid module name: %S"
|
||||
|
||||
let module_name sexp =
|
||||
let name = string sexp in
|
||||
match name with
|
||||
| "" -> invalid_module_name name sexp
|
||||
| s ->
|
||||
(match s.[0] with
|
||||
| 'A'..'Z' | 'a'..'z' -> ()
|
||||
| _ -> invalid_module_name name sexp);
|
||||
String.iter s ~f:(function
|
||||
| 'A'..'Z' | 'a'..'z' | '0'..'9' | '\'' | '_' -> ()
|
||||
| _ -> invalid_module_name name sexp);
|
||||
String.capitalize s
|
||||
let module_name =
|
||||
Parser.map_validate string ~f:(fun name ->
|
||||
match name with
|
||||
| "" -> invalid_module_name name
|
||||
| s ->
|
||||
try
|
||||
(match s.[0] with
|
||||
| 'A'..'Z' | 'a'..'z' -> ()
|
||||
| _ -> raise_notrace Exit);
|
||||
String.iter s ~f:(function
|
||||
| 'A'..'Z' | 'a'..'z' | '0'..'9' | '\'' | '_' -> ()
|
||||
| _ -> raise_notrace Exit);
|
||||
Ok (String.capitalize s)
|
||||
with Exit ->
|
||||
invalid_module_name name)
|
||||
|
||||
let module_names sexp = String.Set.of_list (list module_name sexp)
|
||||
let module_names =
|
||||
Sexp.Of_sexp.Parser.map ~f:String.Set.of_list (list module_name)
|
||||
|
||||
let invalid_lib_name sexp =
|
||||
of_sexp_error sexp "invalid library name"
|
||||
let invalid_lib_name = Parser.error "invalid library name"
|
||||
|
||||
let library_name sexp =
|
||||
match string sexp with
|
||||
| "" -> invalid_lib_name sexp
|
||||
| s ->
|
||||
if s.[0] = '.' then invalid_lib_name sexp;
|
||||
String.iter s ~f:(function
|
||||
| 'A'..'Z' | 'a'..'z' | '_' | '.' | '0'..'9' -> ()
|
||||
| _ -> invalid_lib_name sexp);
|
||||
s
|
||||
let library_name =
|
||||
Parser.map_validate string ~f:(function
|
||||
| "" -> invalid_lib_name
|
||||
| s ->
|
||||
if s.[0] = '.' then invalid_lib_name
|
||||
else
|
||||
try
|
||||
String.iter s ~f:(function
|
||||
| 'A'..'Z' | 'a'..'z' | '_' | '.' | '0'..'9' -> ()
|
||||
| _ -> raise_notrace Exit);
|
||||
Ok s
|
||||
with Exit -> invalid_lib_name)
|
||||
|
||||
let file sexp =
|
||||
match string sexp with
|
||||
| "." | ".." ->
|
||||
of_sexp_error sexp "'.' and '..' are not valid filenames"
|
||||
| fn -> fn
|
||||
let file =
|
||||
Parser.map_validate string ~f:(function
|
||||
| "." | ".." -> Parser.error "'.' and '..' are not valid filenames"
|
||||
| fn -> Ok fn)
|
||||
|
||||
let file_in_current_dir sexp =
|
||||
match string sexp with
|
||||
| "." | ".." ->
|
||||
of_sexp_error sexp "'.' and '..' are not valid filenames"
|
||||
| fn ->
|
||||
if Filename.dirname fn <> Filename.current_dir_name then
|
||||
of_sexp_error sexp "file in current directory expected";
|
||||
fn
|
||||
let file_in_current_dir =
|
||||
Parser.map_validate string ~f:(function
|
||||
|
||||
let relative_file sexp =
|
||||
let fn = file sexp in
|
||||
if not (Filename.is_relative fn) then
|
||||
of_sexp_error sexp "relative filename expected";
|
||||
fn
|
||||
| "." | ".." -> Parser.error "'.' and '..' are not valid filenames"
|
||||
| fn ->
|
||||
if Filename.dirname fn <> Filename.current_dir_name then
|
||||
Parser.error "file in current directory expected"
|
||||
else
|
||||
Ok fn)
|
||||
|
||||
let relative_file =
|
||||
Parser.map_validate file ~f:(fun fn ->
|
||||
if Filename.is_relative fn then
|
||||
Ok fn
|
||||
else
|
||||
Parser.error "relative filename expected")
|
||||
|
||||
let c_name, cxx_name =
|
||||
let make what ext sexp =
|
||||
let s = string sexp in
|
||||
if match s with
|
||||
| "" | "." | ".." -> true
|
||||
| _ -> Filename.basename s <> s then
|
||||
of_sexp_errorf sexp
|
||||
"%S is not a valid %s name.\n\
|
||||
Hint: To use %s files from another directory, use a \
|
||||
(copy_files <dir>/*.%s) stanza instead."
|
||||
s what what ext
|
||||
else
|
||||
s
|
||||
let make what ext =
|
||||
Parser.map_validate string ~f:(fun s ->
|
||||
if match s with
|
||||
| "" | "." | ".." -> true
|
||||
| _ -> Filename.basename s <> s then
|
||||
Parser.errorf
|
||||
"%S is not a valid %s name.\n\
|
||||
Hint: To use %s files from another directory, use a \
|
||||
(copy_files <dir>/*.%s) stanza instead."
|
||||
s what what ext
|
||||
else
|
||||
Ok s)
|
||||
in
|
||||
(make "C" "c",
|
||||
make "C++" "cpp")
|
||||
|
@ -144,10 +151,12 @@ module Pkg = struct
|
|||
(hint name_s (Package.Name.Map.keys project.packages
|
||||
|> List.map ~f:Package.Name.to_string)))
|
||||
|
||||
let t p sexp =
|
||||
match resolve p (Package.Name.of_string (string sexp)) with
|
||||
| Ok p -> p
|
||||
| Error s -> Loc.fail (Sexp.Ast.loc sexp) "%s" s
|
||||
let t p =
|
||||
let open Parser.O in
|
||||
Package.Name.t >>= fun name ->
|
||||
match resolve p name with
|
||||
| Ok x -> Parser.return x
|
||||
| Error e -> Parser.fail "%s" e
|
||||
|
||||
let field p =
|
||||
map_validate (field_o "package" string) ~f:(function
|
||||
|
@ -183,9 +192,9 @@ module Pp_or_flags = struct
|
|||
else
|
||||
PP (loc, Pp.of_string s)
|
||||
|
||||
let t = function
|
||||
let t = Sexp.Of_sexp.make (function
|
||||
| Atom (loc, A s) | Quoted_string (loc, s) -> of_string ~loc s
|
||||
| List (_, l) -> Flags (List.map l ~f:string)
|
||||
| List (_, l) -> Flags (List.map l ~f:(parse string)))
|
||||
|
||||
let split l =
|
||||
let pps, flags =
|
||||
|
@ -219,10 +228,10 @@ module Dep_conf = struct
|
|||
; "universe" , return Universe
|
||||
]
|
||||
in
|
||||
fun sexp ->
|
||||
Sexp.Of_sexp.make (fun sexp ->
|
||||
match sexp with
|
||||
| Atom _ | Quoted_string _ -> File (String_with_vars.t sexp)
|
||||
| List _ -> t sexp
|
||||
| Atom _ | Quoted_string _ -> File (parse String_with_vars.t sexp)
|
||||
| List _ -> parse t sexp)
|
||||
|
||||
open Sexp
|
||||
let sexp_of_t = function
|
||||
|
@ -274,20 +283,20 @@ end
|
|||
module Per_module = struct
|
||||
include Per_item.Make(Module.Name)
|
||||
|
||||
let t ~default a sexp =
|
||||
let t ~default a = Sexp.Of_sexp.make (fun sexp ->
|
||||
match sexp with
|
||||
| List (_, Atom (_, A "per_module") :: rest) -> begin
|
||||
List.map rest ~f:(fun sexp ->
|
||||
let pp, names = pair a module_names sexp in
|
||||
(List.map ~f:Module.Name.of_string (String.Set.to_list names), pp))
|
||||
|> of_mapping ~default
|
||||
|> function
|
||||
| Ok t -> t
|
||||
| Error (name, _, _) ->
|
||||
of_sexp_error sexp (sprintf "module %s present in two different sets"
|
||||
(Module.Name.to_string name))
|
||||
end
|
||||
| sexp -> for_all (a sexp)
|
||||
List.map rest ~f:(fun sexp ->
|
||||
let pp, names = parse (pair a module_names) sexp in
|
||||
(List.map ~f:Module.Name.of_string (String.Set.to_list names), pp))
|
||||
|> of_mapping ~default
|
||||
|> function
|
||||
| Ok t -> t
|
||||
| Error (name, _, _) ->
|
||||
of_sexp_error sexp (sprintf "module %s present in two different sets"
|
||||
(Module.Name.to_string name))
|
||||
end
|
||||
| sexp -> for_all (parse a sexp))
|
||||
end
|
||||
|
||||
module Preprocess_map = struct
|
||||
|
@ -368,7 +377,7 @@ module Lib_dep = struct
|
|||
name);
|
||||
{ required
|
||||
; forbidden
|
||||
; file = file fsexp
|
||||
; file = parse file fsexp
|
||||
}
|
||||
| Atom (_, A "->") :: _
|
||||
| List _ :: _ | [] ->
|
||||
|
@ -384,16 +393,16 @@ module Lib_dep = struct
|
|||
loop String.Set.empty String.Set.empty l
|
||||
| sexp -> of_sexp_error sexp "(<library-name> <code>) expected"
|
||||
|
||||
let t = function
|
||||
let t = Sexp.Of_sexp.make (function
|
||||
| Atom (loc, A s) | Quoted_string (loc, s) ->
|
||||
Direct (loc, s)
|
||||
| List (loc, Atom (_, A "select") :: m :: Atom (_, A "from") :: libs) ->
|
||||
Select { result_fn = file m
|
||||
Select { result_fn = parse file m
|
||||
; choices = List.map libs ~f:choice
|
||||
; loc
|
||||
}
|
||||
| sexp ->
|
||||
of_sexp_error sexp "<library> or (select <module> from <libraries...>) expected"
|
||||
of_sexp_error sexp "<library> or (select <module> from <libraries...>) expected")
|
||||
|
||||
let to_lib_names = function
|
||||
| Direct (_, s) -> [s]
|
||||
|
@ -415,8 +424,8 @@ module Lib_deps = struct
|
|||
| Optional
|
||||
| Forbidden
|
||||
|
||||
let t sexp =
|
||||
let t = list Lib_dep.t sexp in
|
||||
let t = Sexp.Of_sexp.make (fun sexp ->
|
||||
let t = parse (list Lib_dep.t) sexp in
|
||||
let add kind name acc =
|
||||
match String.Map.find acc name with
|
||||
| None -> String.Map.add acc name kind
|
||||
|
@ -444,7 +453,7 @@ module Lib_deps = struct
|
|||
let acc = String.Set.fold c.Lib_dep.required ~init:acc ~f:(add Optional) in
|
||||
String.Set.fold c.forbidden ~init:acc ~f:(add Forbidden)))
|
||||
: kind String.Map.t);
|
||||
t
|
||||
t)
|
||||
|
||||
let of_pps pps =
|
||||
List.map pps ~f:(fun pp -> Lib_dep.of_pp (Loc.none, pp))
|
||||
|
@ -623,7 +632,7 @@ module Mode_conf = struct
|
|||
module Set = struct
|
||||
include Set.Make(T)
|
||||
|
||||
let t sexp = of_list (list t sexp)
|
||||
let t = Sexp.Of_sexp.Parser.map ~f:of_list (list t)
|
||||
|
||||
let default = of_list [Byte; Best]
|
||||
|
||||
|
@ -702,7 +711,7 @@ module Library = struct
|
|||
field "self_build_stubs_archive" (option string) ~default:None >>= fun self_build_stubs_archive ->
|
||||
field_b "no_dynlink" >>= fun no_dynlink ->
|
||||
Sub_system_info.record_parser () >>= fun sub_systems ->
|
||||
field "ppx.driver" ignore ~default:() >>= fun () ->
|
||||
field "ppx.driver" discard ~default:() >>= fun () ->
|
||||
return
|
||||
{ name
|
||||
; public
|
||||
|
@ -747,14 +756,13 @@ module Install_conf = struct
|
|||
; dst : string option
|
||||
}
|
||||
|
||||
let file sexp =
|
||||
match sexp with
|
||||
let file = Sexp.Of_sexp.make (function
|
||||
| Atom (_, A src) -> { src; dst = None }
|
||||
| List (_, [Atom (_, A src); Atom (_, A "as"); Atom (_, A dst)]) ->
|
||||
{ src; dst = Some dst }
|
||||
| _ ->
|
||||
| sexp ->
|
||||
of_sexp_error sexp
|
||||
"invalid format, <name> or (<name> as <install-as>) expected"
|
||||
"invalid format, <name> or (<name> as <install-as>) expected")
|
||||
|
||||
type t =
|
||||
{ section : Install.Section.t
|
||||
|
@ -822,12 +830,12 @@ module Executables = struct
|
|||
let simple =
|
||||
Sexp.Of_sexp.enum simple_representations
|
||||
|
||||
let t sexp =
|
||||
let t = Sexp.Of_sexp.make (fun sexp ->
|
||||
match sexp with
|
||||
| List _ ->
|
||||
let mode, kind = pair Mode_conf.t Binary_kind.t sexp in
|
||||
let mode, kind = parse (pair Mode_conf.t Binary_kind.t) sexp in
|
||||
{ mode; kind }
|
||||
| _ -> simple sexp
|
||||
| _ -> parse simple sexp)
|
||||
|
||||
let simple_sexp_of_t link_mode =
|
||||
let is_ok (_, candidate) =
|
||||
|
@ -847,19 +855,19 @@ module Executables = struct
|
|||
module Set = struct
|
||||
include Set.Make(T)
|
||||
|
||||
let t sexp : t =
|
||||
match list t sexp with
|
||||
| [] -> of_sexp_error sexp "No linking mode defined"
|
||||
| l ->
|
||||
let t = of_list l in
|
||||
if (mem t native_exe && mem t exe ) ||
|
||||
(mem t native_object && mem t object_ ) ||
|
||||
(mem t native_shared_object && mem t shared_object) then
|
||||
of_sexp_error sexp
|
||||
"It is not allowed use both native and best \
|
||||
for the same binary kind."
|
||||
else
|
||||
t
|
||||
let t =
|
||||
Parser.map_validate (list t) ~f:(function
|
||||
| [] -> Parser.error "No linking mode defined"
|
||||
| l ->
|
||||
let t = of_list l in
|
||||
if (mem t native_exe && mem t exe ) ||
|
||||
(mem t native_object && mem t object_ ) ||
|
||||
(mem t native_shared_object && mem t shared_object) then
|
||||
Parser.error
|
||||
"It is not allowed use both native and best \
|
||||
for the same binary kind."
|
||||
else
|
||||
Ok t)
|
||||
|
||||
let default =
|
||||
of_list
|
||||
|
@ -894,7 +902,8 @@ module Executables = struct
|
|||
field "modes" Link_mode.Set.t ~default:Link_mode.Set.default
|
||||
>>= fun modes ->
|
||||
map_validate
|
||||
(field "inline_tests" (fun _ -> true) ~default:false ~short:(This true))
|
||||
(field "inline_tests" (Parser.return true)
|
||||
~default:false ~short:(This true))
|
||||
~f:(function
|
||||
| false -> Ok ()
|
||||
| true ->
|
||||
|
@ -944,7 +953,7 @@ module Executables = struct
|
|||
in
|
||||
match to_install with
|
||||
| [] ->
|
||||
(field_o "package" Sexp.Ast.loc >>= function
|
||||
(field_o "package" loc >>= function
|
||||
| None -> return (t, None)
|
||||
| Some loc ->
|
||||
Loc.warn loc
|
||||
|
@ -955,10 +964,10 @@ module Executables = struct
|
|||
Pkg.field project >>= fun package ->
|
||||
return (t, Some { Install_conf. section = Bin; files; package })
|
||||
|
||||
let public_name sexp =
|
||||
match string sexp with
|
||||
| "-" -> None
|
||||
| s -> Some s
|
||||
let public_name =
|
||||
Parser.map string ~f:(function
|
||||
| "-" -> None
|
||||
| s -> Some s)
|
||||
|
||||
let multi ~syntax project =
|
||||
record
|
||||
|
@ -1018,63 +1027,64 @@ module Rule = struct
|
|||
; loc : Loc.t
|
||||
}
|
||||
|
||||
let v1 sexp =
|
||||
let v1 = Sexp.Of_sexp.make (fun sexp ->
|
||||
let loc = Sexp.Ast.loc sexp in
|
||||
match sexp with
|
||||
| List (loc, (Atom _ :: _)) ->
|
||||
{ targets = Infer
|
||||
; deps = []
|
||||
; action = (loc, Action.Unexpanded.t sexp)
|
||||
; action = (loc, parse Action.Unexpanded.t sexp)
|
||||
; mode = Standard
|
||||
; locks = []
|
||||
; loc = loc
|
||||
}
|
||||
| _ ->
|
||||
record
|
||||
(field "targets" (list file_in_current_dir) >>= fun targets ->
|
||||
field "deps" (list Dep_conf.t) ~default:[] >>= fun deps ->
|
||||
field "action" (located Action.Unexpanded.t) >>= fun action ->
|
||||
field "locks" (list String_with_vars.t) ~default:[] >>= fun locks ->
|
||||
map_validate
|
||||
(field_b "fallback" >>= fun fallback ->
|
||||
field_o "mode" Mode.t >>= fun mode ->
|
||||
return (fallback, mode))
|
||||
~f:(function
|
||||
| true, Some _ ->
|
||||
Error "Cannot use both (fallback) and (mode ...) at the \
|
||||
same time.\n\
|
||||
(fallback) is the same as (mode fallback), \
|
||||
please use the latter in new code."
|
||||
| false, Some mode -> Ok mode
|
||||
| true, None -> Ok Fallback
|
||||
| false, None -> Ok Standard)
|
||||
>>= fun mode ->
|
||||
return { targets = Static targets
|
||||
; deps
|
||||
; action
|
||||
; mode
|
||||
; locks
|
||||
; loc
|
||||
})
|
||||
sexp
|
||||
parse (
|
||||
record
|
||||
(field "targets" (list file_in_current_dir) >>= fun targets ->
|
||||
field "deps" (list Dep_conf.t) ~default:[] >>= fun deps ->
|
||||
field "action" (located Action.Unexpanded.t) >>= fun action ->
|
||||
field "locks" (list String_with_vars.t) ~default:[] >>= fun locks ->
|
||||
map_validate
|
||||
(field_b "fallback" >>= fun fallback ->
|
||||
field_o "mode" Mode.t >>= fun mode ->
|
||||
return (fallback, mode))
|
||||
~f:(function
|
||||
| true, Some _ ->
|
||||
Error "Cannot use both (fallback) and (mode ...) at the \
|
||||
same time.\n\
|
||||
(fallback) is the same as (mode fallback), \
|
||||
please use the latter in new code."
|
||||
| false, Some mode -> Ok mode
|
||||
| true, None -> Ok Fallback
|
||||
| false, None -> Ok Standard)
|
||||
>>= fun mode ->
|
||||
return { targets = Static targets
|
||||
; deps
|
||||
; action
|
||||
; mode
|
||||
; locks
|
||||
; loc
|
||||
}))
|
||||
sexp)
|
||||
|
||||
type lex_or_yacc =
|
||||
{ modules : string list
|
||||
; mode : Mode.t
|
||||
}
|
||||
|
||||
let ocamllex_v1 sexp =
|
||||
let ocamllex_v1 = Sexp.Of_sexp.make (fun sexp ->
|
||||
match sexp with
|
||||
| List (_, List (_, _) :: _) ->
|
||||
record
|
||||
(field "modules" (list string) >>= fun modules ->
|
||||
Mode.field >>= fun mode ->
|
||||
return { modules; mode })
|
||||
sexp
|
||||
parse (
|
||||
record
|
||||
(field "modules" (list string) >>= fun modules ->
|
||||
Mode.field >>= fun mode ->
|
||||
return { modules; mode })) sexp
|
||||
| _ ->
|
||||
{ modules = list string sexp
|
||||
{ modules = parse (list string) sexp
|
||||
; mode = Standard
|
||||
}
|
||||
})
|
||||
|
||||
let ocamlyacc_v1 = ocamllex_v1
|
||||
|
||||
|
@ -1152,12 +1162,12 @@ module Alias_conf = struct
|
|||
; package : Package.t option
|
||||
}
|
||||
|
||||
let alias_name sexp =
|
||||
let s = string sexp in
|
||||
if Filename.basename s <> s then
|
||||
of_sexp_errorf sexp "%S is not a valid alias name" s
|
||||
else
|
||||
s
|
||||
let alias_name =
|
||||
Parser.map_validate string ~f:(fun s ->
|
||||
if Filename.basename s <> s then
|
||||
Parser.errorf "%S is not a valid alias name" s
|
||||
else
|
||||
Ok s)
|
||||
|
||||
let v1 project =
|
||||
record
|
||||
|
@ -1224,17 +1234,17 @@ module Env = struct
|
|||
field_oslu "ocamlopt_flags" >>= fun ocamlopt_flags ->
|
||||
return { flags; ocamlc_flags; ocamlopt_flags })
|
||||
|
||||
let rule = function
|
||||
let rule = Sexp.Of_sexp.make (function
|
||||
| List (loc, Atom (_, A pat) :: fields) ->
|
||||
let pat =
|
||||
match pat with
|
||||
| "_" -> Any
|
||||
| s -> Profile s
|
||||
in
|
||||
(pat, config (List (loc, fields)))
|
||||
(pat, parse config (List (loc, fields)))
|
||||
| sexp ->
|
||||
of_sexp_error sexp
|
||||
"S-expression of the form (<profile> <fields>) expected"
|
||||
"S-expression of the form (<profile> <fields>) expected")
|
||||
end
|
||||
|
||||
type Stanza.t +=
|
||||
|
@ -1329,7 +1339,7 @@ module Stanzas = struct
|
|||
exception Include_loop of Path.t * (Loc.t * Path.t) list
|
||||
|
||||
let rec parse stanza_parser ~current_file ~include_stack sexps =
|
||||
List.concat_map sexps ~f:stanza_parser
|
||||
List.concat_map sexps ~f:(Sexp.Of_sexp.parse stanza_parser)
|
||||
|> List.concat_map ~f:(function
|
||||
| Include (loc, fn) ->
|
||||
let include_stack = (loc, current_file) :: include_stack in
|
||||
|
|
|
@ -73,7 +73,7 @@ module Dict = struct
|
|||
; native = List.mem Native ~set:l
|
||||
}
|
||||
|
||||
let t sexp = of_list (Sexp.Of_sexp.list t sexp)
|
||||
let t = Sexp.Of_sexp.(Parser.map (list t) ~f:of_list)
|
||||
|
||||
let is_empty t = not (t.byte || t.native)
|
||||
|
||||
|
|
|
@ -40,7 +40,7 @@ let parse_general sexp ~f =
|
|||
in
|
||||
of_sexp sexp
|
||||
|
||||
let t sexp : t =
|
||||
let t = Sexp.Of_sexp.make (fun sexp ->
|
||||
let ast =
|
||||
parse_general sexp ~f:(function
|
||||
| Atom (loc, A s) | Quoted_string (loc, s) -> (loc, s)
|
||||
|
@ -48,7 +48,7 @@ let t sexp : t =
|
|||
in
|
||||
{ ast
|
||||
; loc = Some (Sexp.Ast.loc sexp)
|
||||
}
|
||||
})
|
||||
|
||||
let is_standard t =
|
||||
match (t.ast : ast_expanded) with
|
||||
|
@ -171,13 +171,13 @@ let standard =
|
|||
module Unexpanded = struct
|
||||
type ast = (Sexp.Ast.t, Ast.unexpanded) Ast.t
|
||||
type t = ast generic
|
||||
let t sexp =
|
||||
let t = Sexp.Of_sexp.make (fun sexp ->
|
||||
let rec map (t : (Sexp.Ast.t, Ast.expanded) Ast.t) =
|
||||
let open Ast in
|
||||
match t with
|
||||
| Element x -> Element x
|
||||
| Union [Special (_, "include"); Element fn] ->
|
||||
Include (String_with_vars.t fn)
|
||||
Include (Sexp.Of_sexp.parse String_with_vars.t fn)
|
||||
| Union [Special (loc, "include"); _]
|
||||
| Special (loc, "include") ->
|
||||
Loc.fail loc "(:include expects a single element (do you need to quote the filename?)"
|
||||
|
@ -189,7 +189,7 @@ module Unexpanded = struct
|
|||
in
|
||||
{ ast = map (parse_general sexp ~f:(fun x -> x))
|
||||
; loc = Some (Sexp.Ast.loc sexp)
|
||||
}
|
||||
})
|
||||
|
||||
let sexp_of_t t =
|
||||
let open Ast in
|
||||
|
@ -241,7 +241,8 @@ module Unexpanded = struct
|
|||
let rec expand (t : ast) : ast_expanded =
|
||||
let open Ast in
|
||||
match t with
|
||||
| Element s -> Element (Sexp.Ast.loc s, f (String_with_vars.t s))
|
||||
| Element s ->
|
||||
Element (Sexp.Ast.loc s, f (Sexp.Of_sexp.parse String_with_vars.t s))
|
||||
| Special (l, s) -> Special (l, s)
|
||||
| Include fn ->
|
||||
let sexp =
|
||||
|
@ -257,7 +258,7 @@ module Unexpanded = struct
|
|||
]
|
||||
in
|
||||
parse_general sexp ~f:(fun sexp ->
|
||||
(Sexp.Ast.loc sexp, f (String_with_vars.t sexp)))
|
||||
(Sexp.Ast.loc sexp, f (Sexp.Of_sexp.parse String_with_vars.t sexp)))
|
||||
| Union l -> Union (List.map l ~f:expand)
|
||||
| Diff (l, r) ->
|
||||
Diff (expand l, expand r)
|
||||
|
|
|
@ -12,6 +12,8 @@ module Name = struct
|
|||
let opam_fn (t : t) = to_string t ^ ".opam"
|
||||
|
||||
let pp fmt t = Format.pp_print_string fmt (to_string t)
|
||||
|
||||
let t = Sexp.Of_sexp.(Parser.map ~f:of_string string)
|
||||
end
|
||||
|
||||
|
||||
|
|
|
@ -12,6 +12,8 @@ module Name : sig
|
|||
val pp : Format.formatter -> t -> unit
|
||||
|
||||
include Interned.S with type t := t
|
||||
|
||||
val t : t Sexp.Of_sexp.t
|
||||
end
|
||||
|
||||
type t =
|
||||
|
|
|
@ -188,7 +188,7 @@ module Jbuild_driver = struct
|
|||
let make name info : (Pp.t * Driver.t) Lazy.t = lazy (
|
||||
let info =
|
||||
Sexp.parse_string ~mode:Single ~fname:"<internal>" info
|
||||
|> Driver.Info.parse
|
||||
|> Sexp.Of_sexp.parse Driver.Info.parse
|
||||
in
|
||||
(Pp.of_string name,
|
||||
{ info
|
||||
|
|
|
@ -70,11 +70,12 @@ end = struct
|
|||
make t
|
||||
|
||||
let sexp_of_t t = Sexp.To_sexp.string (to_string t)
|
||||
let t sexp =
|
||||
let t = Sexp.Of_sexp.string sexp in
|
||||
if Filename.is_relative t then
|
||||
Sexp.Of_sexp.of_sexp_error sexp "Absolute path expected";
|
||||
of_string t
|
||||
let t = Sexp.Of_sexp.(
|
||||
Parser.map_validate string ~f:(fun t ->
|
||||
if Filename.is_relative t then
|
||||
Parser.error "Absolute path expected"
|
||||
else
|
||||
Ok (of_string t)))
|
||||
|
||||
(*
|
||||
let rec cd_dot_dot t =
|
||||
|
@ -276,9 +277,9 @@ end = struct
|
|||
| _ ->
|
||||
relative root s ?error_loc
|
||||
|
||||
let t sexp =
|
||||
of_string (Sexp.Of_sexp.string sexp)
|
||||
~error_loc:(Sexp.Ast.loc sexp)
|
||||
let t = Sexp.Of_sexp.(
|
||||
Parser.map (located string) ~f:(fun (error_loc, s) ->
|
||||
of_string s ~error_loc))
|
||||
|
||||
let rec mkdir_p t =
|
||||
if is_root t then
|
||||
|
@ -587,18 +588,20 @@ let of_string ?error_loc s =
|
|||
else
|
||||
make_local_path (Local.of_string s ?error_loc)
|
||||
|
||||
let t = function
|
||||
(* the first 2 cases are necessary for old build dirs *)
|
||||
| Sexp.Ast.Atom (_, A s)
|
||||
| Quoted_string (_, s) -> of_string s
|
||||
| s ->
|
||||
let open Sexp.Of_sexp in
|
||||
sum
|
||||
[ "In_build_dir" , next Local.t >>| in_build_dir
|
||||
; "In_source_tree", next Local.t >>| in_source_tree
|
||||
; "External" , next External.t >>| external_
|
||||
]
|
||||
s
|
||||
let t =
|
||||
Sexp.Of_sexp.make (function
|
||||
(* the first 2 cases are necessary for old build dirs *)
|
||||
| Sexp.Ast.Atom (_, A s)
|
||||
| Quoted_string (_, s) -> of_string s
|
||||
| s ->
|
||||
let open Sexp.Of_sexp in
|
||||
parse (
|
||||
sum
|
||||
[ "In_build_dir" , next Local.t >>| in_build_dir
|
||||
; "In_source_tree", next Local.t >>| in_source_tree
|
||||
; "External" , next External.t >>| external_
|
||||
])
|
||||
s)
|
||||
|
||||
let sexp_of_t t =
|
||||
let constr f x y = Sexp.To_sexp.(pair string f) (x, y) in
|
||||
|
|
|
@ -2,6 +2,8 @@ type ('a, 'error) t = ('a, 'error) Caml.result =
|
|||
| Ok of 'a
|
||||
| Error of 'error
|
||||
|
||||
let ok x = Ok x
|
||||
|
||||
let is_ok = function
|
||||
| Ok _ -> true
|
||||
| Error _ -> false
|
||||
|
|
|
@ -4,6 +4,8 @@ type ('a, 'error) t = ('a, 'error) Caml.result =
|
|||
| Ok of 'a
|
||||
| Error of 'error
|
||||
|
||||
val ok : 'a -> ('a, _) t
|
||||
|
||||
val is_ok : _ t -> bool
|
||||
val is_error : _ t -> bool
|
||||
|
||||
|
|
|
@ -74,12 +74,47 @@ module Of_sexp = struct
|
|||
|
||||
type 'a t = ast -> 'a
|
||||
|
||||
let make f = f
|
||||
|
||||
let parse f a = f a
|
||||
|
||||
module Parser = struct
|
||||
let fail fmt =
|
||||
Printf.ksprintf (fun m ast -> raise (Exn.Loc_error (Ast.loc ast, m))) fmt
|
||||
let map t ~f ast = f (t ast)
|
||||
let return a _ = a
|
||||
|
||||
module O = struct
|
||||
let (>>|) t f = map t ~f
|
||||
let (>>=) t f ast = f (t ast) ast
|
||||
end
|
||||
|
||||
type error = string * hint option
|
||||
|
||||
let error ?hint str = Error (str, hint)
|
||||
let errorf ?hint fmt = Printf.ksprintf (error ?hint) fmt
|
||||
|
||||
let map_validate t ~f ast =
|
||||
match f (t ast) with
|
||||
| Ok b -> b
|
||||
| Error (msg, hint) -> raise (Of_sexp (Ast.loc ast, msg, hint))
|
||||
end
|
||||
|
||||
let fix f =
|
||||
let rec p = lazy (f r)
|
||||
and r ast = (Lazy.force p) ast in
|
||||
r
|
||||
|
||||
let located f sexp =
|
||||
(Ast.loc sexp, f sexp)
|
||||
|
||||
let loc = Ast.loc
|
||||
|
||||
let of_sexp_error ?hint sexp str = raise (Of_sexp (Ast.loc sexp, str, hint))
|
||||
let of_sexp_errorf ?hint sexp fmt = Printf.ksprintf (of_sexp_error ?hint sexp) fmt
|
||||
|
||||
let sexp_error ?hint str sexp = of_sexp_error ?hint sexp str
|
||||
|
||||
let of_sexp_errorf_loc ?hint loc fmt =
|
||||
Printf.ksprintf (fun s -> raise (Of_sexp (loc, s, hint))) fmt
|
||||
|
||||
|
@ -89,6 +124,8 @@ module Of_sexp = struct
|
|||
| List (_, []) -> ()
|
||||
| sexp -> of_sexp_error sexp "() expected"
|
||||
|
||||
let discard (_ : ast) = ()
|
||||
|
||||
let string = function
|
||||
| Atom (_, A s) -> s
|
||||
| Quoted_string (_, s) -> s
|
||||
|
|
|
@ -65,13 +65,42 @@ module Of_sexp : sig
|
|||
|
||||
exception Of_sexp of Loc.t * string * hint option
|
||||
|
||||
include Combinators with type 'a t = Ast.t -> 'a
|
||||
include Combinators
|
||||
|
||||
val parse : 'a t -> ast -> 'a
|
||||
|
||||
val make : (ast -> 'a) -> 'a t
|
||||
|
||||
val discard : unit t
|
||||
|
||||
module Parser : sig
|
||||
val fail : ('a, unit, string, string, string, 'b t) format6 -> 'a
|
||||
val map : 'a t -> f:('a -> 'b) -> 'b t
|
||||
val return : 'a -> 'a t
|
||||
|
||||
module O : sig
|
||||
val (>>|) : 'a t -> ('a -> 'b) -> 'b t
|
||||
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
|
||||
end
|
||||
|
||||
type error
|
||||
|
||||
val error : ?hint:hint -> string -> (_, error) Result.t
|
||||
val errorf
|
||||
: ?hint:hint -> ('b, unit, string, (_, error) result) format4 -> 'b
|
||||
val map_validate : 'a t -> f:('a -> ('b, error) Result.t) -> 'b t
|
||||
end
|
||||
|
||||
val fix : ('a t -> 'a t) -> 'a t
|
||||
|
||||
val sexp_error : ?hint:hint -> string -> _ t
|
||||
val of_sexp_error : ?hint:hint -> Ast.t -> string -> _
|
||||
val of_sexp_errorf : ?hint:hint -> Ast.t -> ('a, unit, string, 'b) format4 -> 'a
|
||||
|
||||
val located : 'a t -> (Loc.t * 'a) t
|
||||
|
||||
val loc : Loc.t t
|
||||
|
||||
val raw : ast t
|
||||
|
||||
val enum : (string * 'a) list -> 'a t
|
||||
|
|
|
@ -59,11 +59,12 @@ let rec of_tokens : Token.t list -> item list = function
|
|||
|
||||
let items_of_string s = of_tokens (Token.tokenise s)
|
||||
|
||||
let t : Sexp.Of_sexp.ast -> t = function
|
||||
| Atom(loc, A s) -> { items = items_of_string s; loc; quoted = false }
|
||||
| Quoted_string (loc, s) ->
|
||||
{ items = items_of_string s; loc; quoted = true }
|
||||
| List _ as sexp -> Sexp.Of_sexp.of_sexp_error sexp "Atom expected"
|
||||
let t =
|
||||
Sexp.Of_sexp.make (function
|
||||
| Atom(loc, A s) -> { items = items_of_string s; loc; quoted = false }
|
||||
| Quoted_string (loc, s) ->
|
||||
{ items = items_of_string s; loc; quoted = true }
|
||||
| List _ as sexp -> Sexp.Of_sexp.of_sexp_error sexp "Atom expected")
|
||||
|
||||
let loc t = t.loc
|
||||
|
||||
|
|
|
@ -7,7 +7,7 @@ module Version = struct
|
|||
|
||||
let sexp_of_t t = Sexp.unsafe_atom_of_string (to_string t)
|
||||
|
||||
let t : t Sexp.Of_sexp.t = function
|
||||
let t : t Sexp.Of_sexp.t = Sexp.Of_sexp.make (function
|
||||
| Atom (loc, A s) -> begin
|
||||
try
|
||||
Scanf.sscanf s "%u.%u" (fun a b -> (a, b))
|
||||
|
@ -15,7 +15,7 @@ module Version = struct
|
|||
Loc.fail loc "atom of the form NNN.NNN expected"
|
||||
end
|
||||
| sexp ->
|
||||
Sexp.Of_sexp.of_sexp_error sexp "atom expected"
|
||||
Sexp.Of_sexp.of_sexp_error sexp "atom expected")
|
||||
|
||||
let can_read ~parser_version:(pa, pb) ~data_version:(da, db) =
|
||||
pa = da && db <= pb
|
||||
|
|
|
@ -66,7 +66,7 @@ module Make
|
|||
struct
|
||||
module Of_sexp = struct
|
||||
include F(Sexp.Of_sexp)
|
||||
let t _ sexp = t sexp
|
||||
let t _ sexp = Sexp.Of_sexp.parse t sexp
|
||||
end
|
||||
module To_sexp = struct
|
||||
include F(Sexp.To_sexp)
|
||||
|
|
|
@ -7,10 +7,10 @@ module Context = struct
|
|||
| Native
|
||||
| Named of string
|
||||
|
||||
let t sexp =
|
||||
match string sexp with
|
||||
| "native" -> Native
|
||||
| s -> Named s
|
||||
let t =
|
||||
Parser.map string ~f:(function
|
||||
| "native" -> Native
|
||||
| s -> Named s)
|
||||
end
|
||||
|
||||
module Opam = struct
|
||||
|
@ -55,22 +55,24 @@ module Context = struct
|
|||
|
||||
type t = Default of Default.t | Opam of Opam.t
|
||||
|
||||
let t ~profile = function
|
||||
let t ~profile = Sexp.Of_sexp.make (function
|
||||
| Atom (_, A "default") ->
|
||||
Default { targets = [Native]
|
||||
; profile
|
||||
}
|
||||
| List (_, List _ :: _) as sexp -> Opam (record (Opam.t ~profile) sexp)
|
||||
| List (_, List _ :: _) as sexp ->
|
||||
Opam (Sexp.Of_sexp.parse (record (Opam.t ~profile)) sexp)
|
||||
| sexp ->
|
||||
sum
|
||||
[ "default",
|
||||
(rest_as_record (Default.t ~profile) >>| fun x ->
|
||||
Default x)
|
||||
; "opam",
|
||||
(rest_as_record (Opam.t ~profile) >>| fun x ->
|
||||
Opam x)
|
||||
]
|
||||
sexp
|
||||
Sexp.Of_sexp.parse
|
||||
(sum
|
||||
[ "default",
|
||||
(rest_as_record (Default.t ~profile) >>| fun x ->
|
||||
Default x)
|
||||
; "opam",
|
||||
(rest_as_record (Opam.t ~profile) >>| fun x ->
|
||||
Opam x)
|
||||
])
|
||||
sexp)
|
||||
|
||||
let name = function
|
||||
| Default _ -> "default"
|
||||
|
@ -107,7 +109,7 @@ let t ?x ?profile:cmdline_profile sexps =
|
|||
let defined_names = ref String.Set.empty in
|
||||
let profiles, contexts =
|
||||
List.partition_map sexps ~f:(fun sexp ->
|
||||
match item_of_sexp sexp with
|
||||
match Sexp.Of_sexp.parse item_of_sexp sexp with
|
||||
| Profile (loc, p) -> Left (loc, p)
|
||||
| Context c -> Right c)
|
||||
in
|
||||
|
@ -126,7 +128,7 @@ let t ?x ?profile:cmdline_profile sexps =
|
|||
}
|
||||
in
|
||||
List.fold_left contexts ~init ~f:(fun t sexp ->
|
||||
let ctx = Context.t ~profile sexp in
|
||||
let ctx = Sexp.Of_sexp.parse (Context.t ~profile) sexp in
|
||||
let ctx =
|
||||
match x with
|
||||
| None -> ctx
|
||||
|
|
|
@ -1,3 +1,4 @@
|
|||
(* -*- tuareg -*- *)
|
||||
open Dune;;
|
||||
open Stdune;;
|
||||
|
||||
|
@ -7,7 +8,7 @@ open Stdune;;
|
|||
|
||||
(* Jbuild.Executables.Link_mode.t *)
|
||||
let test s =
|
||||
Jbuild.Executables.Link_mode.t
|
||||
Sexp.Of_sexp.parse Jbuild.Executables.Link_mode.t
|
||||
(Sexp.parse_string ~fname:"" ~mode:Sexp.Parser.Mode.Single s)
|
||||
[%%expect{|
|
||||
val test : string -> Dune.Jbuild.Executables.Link_mode.t = <fun>
|
||||
|
|
|
@ -24,18 +24,18 @@ val sexp : Usexp.Ast.t = ((foo 1) (foo 2))
|
|||
|}]
|
||||
|
||||
let of_sexp = record (field "foo" int)
|
||||
let x = of_sexp sexp
|
||||
let x = parse of_sexp sexp
|
||||
[%%expect{|
|
||||
val of_sexp : int Stdune.Sexp.Of_sexp.t = <fun>
|
||||
val of_sexp : int Stdune.Sexp.Of_sexp.t = <abstr>
|
||||
Exception:
|
||||
Stdune__Sexp.Of_sexp.Of_sexp (<abstr>,
|
||||
"Field \"foo\" is present too many times", None).
|
||||
|}]
|
||||
|
||||
let of_sexp = record (dup_field "foo" int)
|
||||
let x = of_sexp sexp
|
||||
let x = parse of_sexp sexp
|
||||
[%%expect{|
|
||||
val of_sexp : int list Stdune.Sexp.Of_sexp.t = <fun>
|
||||
val of_sexp : int list Stdune.Sexp.Of_sexp.t = <abstr>
|
||||
val x : int list = [1; 2]
|
||||
|}]
|
||||
|
||||
|
|
Loading…
Reference in New Issue