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

Make Sexp.Of_sexp.t abstract 

Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>
This commit is contained in:
Rudi Grinberg 2018-06-15 12:20:03 +07:00 committed by Jeremie Dimino
parent 548bcad64c
commit 065e2bb26f
24 changed files with 432 additions and 338 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

162
src/action.ml
View File

@ -21,78 +21,78 @@ module Make_ast
struct struct
include Ast include Ast
let rec t sexp = let t =
let path = Path.t and string = String.t in let path = Path.t and string = String.t in
sum Sexp.Of_sexp.fix (fun t ->
[ "run", sum
(next Program.t >>= fun prog -> [ "run",
rest string >>| fun args -> (next Program.t >>= fun prog ->
Run (prog, args)) rest string >>| fun args ->
; "chdir", Run (prog, args))
(next path >>= fun dn -> ; "chdir",
next t >>| fun t -> (next path >>= fun dn ->
Chdir (dn, t)) next t >>| fun t ->
; "setenv", Chdir (dn, t))
(next string >>= fun k -> ; "setenv",
next string >>= fun v -> (next string >>= fun k ->
next t >>| fun t -> next string >>= fun v ->
Setenv (k, v, t)) next t >>| fun t ->
; "with-stdout-to", Setenv (k, v, t))
(next path >>= fun fn -> ; "with-stdout-to",
next t >>| fun t -> (next path >>= fun fn ->
Redirect (Stdout, fn, t)) next t >>| fun t ->
; "with-stderr-to", Redirect (Stdout, fn, t))
(next path >>= fun fn -> ; "with-stderr-to",
next t >>| fun t -> (next path >>= fun fn ->
Redirect (Stderr, fn, t)) next t >>| fun t ->
; "with-outputs-to", Redirect (Stderr, fn, t))
(next path >>= fun fn -> ; "with-outputs-to",
next t >>| fun t -> (next path >>= fun fn ->
Redirect (Outputs, fn, t)) next t >>| fun t ->
; "ignore-stdout", Redirect (Outputs, fn, t))
(next t >>| fun t -> Ignore (Stdout, t)) ; "ignore-stdout",
; "ignore-stderr", (next t >>| fun t -> Ignore (Stdout, t))
(next t >>| fun t -> Ignore (Stderr, t)) ; "ignore-stderr",
; "ignore-outputs", (next t >>| fun t -> Ignore (Stderr, t))
(next t >>| fun t -> Ignore (Outputs, t)) ; "ignore-outputs",
; "progn", (next t >>| fun t -> Ignore (Outputs, t))
(rest t >>| fun l -> Progn l) ; "progn",
; "echo", (rest t >>| fun l -> Progn l)
(next string >>= fun x -> ; "echo",
rest string >>| fun xs -> (next string >>= fun x ->
Echo (x :: xs)) rest string >>| fun xs ->
; "cat", Echo (x :: xs))
(next path >>| fun x -> Cat x) ; "cat",
; "copy", (next path >>| fun x -> Cat x)
(next path >>= fun src -> ; "copy",
next path >>| fun dst -> (next path >>= fun src ->
Copy (src, dst)) next path >>| fun dst ->
; "copy#", Copy (src, dst))
(next path >>= fun src -> ; "copy#",
next path >>| fun dst -> (next path >>= fun src ->
Copy_and_add_line_directive (src, dst)) next path >>| fun dst ->
; "copy-and-add-line-directive", Copy_and_add_line_directive (src, dst))
(next path >>= fun src -> ; "copy-and-add-line-directive",
next path >>| fun dst -> (next path >>= fun src ->
Copy_and_add_line_directive (src, dst)) next path >>| fun dst ->
; "system", Copy_and_add_line_directive (src, dst))
(next string >>| fun cmd -> System cmd) ; "system",
; "bash", (next string >>| fun cmd -> System cmd)
(next string >>| fun cmd -> Bash cmd) ; "bash",
; "write-file", (next string >>| fun cmd -> Bash cmd)
(next path >>= fun fn -> ; "write-file",
next string >>| fun s -> (next path >>= fun fn ->
Write_file (fn, s)) next string >>| fun s ->
; "diff", Write_file (fn, s))
(next path >>= fun file1 -> ; "diff",
next path >>| fun file2 -> (next path >>= fun file1 ->
Diff { optional = false; file1; file2 }) next path >>| fun file2 ->
; "diff?", Diff { optional = false; file1; file2 })
(next path >>= fun file1 -> ; "diff?",
next path >>| fun file2 -> (next path >>= fun file1 ->
Diff { optional = true; file1; file2 }) next path >>| fun file2 ->
] Diff { optional = true; file1; file2 })
sexp ])
let rec sexp_of_t : _ -> Sexp.t = let rec sexp_of_t : _ -> Sexp.t =
let path = Path.sexp_of_t and string = String.sexp_of_t in 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 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 let sexp_of_t = function
| Ok s -> Path.sexp_of_t s | 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) include Make_ast(String_with_vars)(String_with_vars)(String_with_vars)(Uast)
let t sexp = let t = Sexp.Of_sexp.make (function
match sexp with | Atom _ | Quoted_string _ as sexp ->
| Atom _ | Quoted_string _ ->
of_sexp_errorf sexp of_sexp_errorf sexp
"if you meant for this to be executed with bash, write (bash \"...\") instead" "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 = let check_mkdir loc path =
if not (Path.is_managed path) then if not (Path.is_managed path) then
@ -582,13 +581,14 @@ module Promotion = struct
; dst : Path.t ; dst : Path.t
} }
let t = function let t = Sexp.Of_sexp.make (function
| Sexp.Ast.List (_, [src; Atom (_, A "as"); dst]) -> | Sexp.Ast.List (_, [src; Atom (_, A "as"); dst]) ->
{ src = Path.t src let open Sexp.Of_sexp in
; dst = Path.t dst { src = parse Path.t src
; dst = parse Path.t dst
} }
| sexp -> | 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 } = let sexp_of_t { src; dst } =
Sexp.List [Path.sexp_of_t src; Sexp.unsafe_atom_of_string "as"; Sexp.List [Path.sexp_of_t src; Sexp.unsafe_atom_of_string "as";
@ -620,7 +620,7 @@ module Promotion = struct
let load_db () = let load_db () =
if Path.exists db_file then if Path.exists db_file then
Io.Sexp.load db_file ~mode:Many Io.Sexp.load db_file ~mode:Many
|> List.map ~f:File.t |> List.map ~f:(Sexp.Of_sexp.parse File.t)
else else
[] []

4
src/build_system.ml
View File

@ -19,7 +19,7 @@ module Promoted_to_delete = struct
let load () = let load () =
if Path.exists fn then if Path.exists fn then
Io.Sexp.load fn ~mode:Many Io.Sexp.load fn ~mode:Many
|> List.map ~f:Path.t |> List.map ~f:(Sexp.Of_sexp.parse Path.t)
else else
[] []
@ -1220,7 +1220,7 @@ let update_universe t =
Utils.Cached_digest.remove universe_file; Utils.Cached_digest.remove universe_file;
let n = let n =
if Path.exists universe_file then 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 else
0 0
in in

11
src/config.ml
View File

@ -62,10 +62,11 @@ module Concurrency = struct
else else
error error
let t sexp = let t =
match of_string (string sexp) with Parser.map_validate string ~f:(fun s ->
| Ok t -> t match of_string s with
| Error msg -> of_sexp_error sexp msg | Error m -> Sexp.Of_sexp.Parser.error m
| Ok _ as s -> s)
let to_string = function let to_string = function
| Auto -> "auto" | Auto -> "auto"
@ -114,7 +115,7 @@ let user_config_file =
"dune/config" "dune/config"
let load_config_file p = 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 () = let load_user_config_file () =
if Path.exists user_config_file then if Path.exists user_config_file then

2
src/context.ml
View File

@ -425,7 +425,7 @@ let create_for_opam ?root ~env ~targets ~profile ~switch ~name
>>= fun s -> >>= fun s ->
let vars = let vars =
Usexp.parse_string ~fname:"<opam output>" ~mode:Single s 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.of_list_multi
|> Env.Map.mapi ~f:(fun var values -> |> Env.Map.mapi ~f:(fun var values ->
match List.rev values with match List.rev values with

24
src/dune_project.ml
View File

@ -70,12 +70,12 @@ end = struct
else else
None None
let named_of_sexp sexp = let named_of_sexp =
let s = string sexp in Sexp.Of_sexp.Parser.map_validate string ~f:(fun s ->
if validate s then if validate s then
Named s Ok (Named s)
else else
of_sexp_error sexp "invalid project name" Sexp.Of_sexp.Parser.error "invalid project name")
let encode = function let encode = function
| Named s -> s | Named s -> s
@ -142,7 +142,9 @@ module Lang = struct
; version = (ver_loc, ver) ; version = (ver_loc, ver)
} = first_line } = first_line
in 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 match Hashtbl.find langs name with
| None -> | None ->
Loc.fail name_loc "Unknown language %S.%s" name Loc.fail name_loc "Unknown language %S.%s" name
@ -196,7 +198,7 @@ let anonymous = lazy(
; packages = Package.Name.Map.empty ; packages = Package.Name.Map.empty
; root = get_local_path Path.root ; root = get_local_path Path.root
; version = None ; version = None
; stanza_parser = (fun _ -> assert false) ; stanza_parser = Sexp.Of_sexp.make (fun _ -> assert false)
; project_file = None ; project_file = None
} }
in in
@ -237,7 +239,7 @@ let parse ~dir ~lang_stanzas ~packages ~file =
; root = get_local_path dir ; root = get_local_path dir
; version ; version
; packages ; packages
; stanza_parser = (fun _ -> assert false) ; stanza_parser = Sexp.Of_sexp.make (fun _ -> assert false)
; project_file = Some file ; project_file = Some file
} }
in in
@ -263,7 +265,7 @@ let load_dune_project ~dir packages =
Io.with_lexbuf_from_file fname ~f:(fun lb -> Io.with_lexbuf_from_file fname ~f:(fun lb ->
let lang_stanzas = Lang.parse (Dune_lexer.first_line lb) in let lang_stanzas = Lang.parse (Dune_lexer.first_line lb) in
let sexp = Sexp.Parser.parse lb ~mode:Many_as_one 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 make_jbuilder_project ~dir packages =
let t = let t =
@ -272,7 +274,7 @@ let make_jbuilder_project ~dir packages =
; root = get_local_path dir ; root = get_local_path dir
; version = None ; version = None
; packages ; packages
; stanza_parser = (fun _ -> assert false) ; stanza_parser = Sexp.Of_sexp.make (fun _ -> assert false)
; project_file = None ; project_file = None
} }
in in

22
src/file_tree.ml
View File

@ -40,16 +40,16 @@ module Dune_file = struct
let extract_ignored_subdirs = let extract_ignored_subdirs =
let stanza = let stanza =
let open Sexp.Of_sexp in let open Sexp.Of_sexp in
let sub_dir sexp = let sub_dir =
let dn = string sexp in Parser.map_validate string ~f:(fun dn ->
if Filename.dirname dn <> Filename.current_dir_name || if Filename.dirname dn <> Filename.current_dir_name ||
match string sexp with match dn with
| "" | "." | ".." -> true | "" | "." | ".." -> true
| _ -> false | _ -> false
then then
of_sexp_errorf sexp "Invalid sub-directory name %S" dn Parser.errorf "Invalid sub-directory name %S" dn
else else
dn Ok dn)
in in
sum sum
[ "ignored_subdirs", next (list sub_dir) >>| String.Set.of_list [ "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 -> List.partition_map sexps ~f:(fun sexp ->
match (sexp : Sexp.Ast.t) with match (sexp : Sexp.Ast.t) with
| List (_, (Atom (_, A "ignored_subdirs") :: _)) -> | List (_, (Atom (_, A "ignored_subdirs") :: _)) ->
Left (stanza sexp) Left (Sexp.Of_sexp.parse stanza sexp)
| _ -> Right sexp) | _ -> Right sexp)
in in
let ignored_subdirs = let ignored_subdirs =

15
src/installed_dune_file.ml
View File

@ -3,7 +3,7 @@ open Import
let parse_sub_systems sexps = let parse_sub_systems sexps =
List.filter_map sexps ~f:(fun sexp -> List.filter_map sexps ~f:(fun sexp ->
let name, ver, data = 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 in
match Sub_system_name.get name with match Sub_system_name.get name with
| None -> | None ->
@ -24,15 +24,14 @@ let parse_sub_systems sexps =
Syntax.Versioned_parser.find_exn M.parsers ~loc:vloc Syntax.Versioned_parser.find_exn M.parsers ~loc:vloc
~data_version:ver ~data_version:ver
in in
M.T (parser.parse data)) M.T (Sexp.Of_sexp.parse parser.parse data))
let of_sexp = let of_sexp =
let open Sexp.Of_sexp in let open Sexp.Of_sexp in
let version sexp = let version =
match string sexp with Parser.map_validate string ~f:(function
| "1" -> () | "1" -> Ok ()
| _ -> | _ -> Parser.error "Unsupported version, only version 1 is supported")
of_sexp_error sexp "Unsupported version, only version 1 is supported"
in in
sum sum
[ "dune", [ "dune",
@ -41,7 +40,7 @@ let of_sexp =
parse_sub_systems l) 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 gen confs =
let sexps = let sexps =

328
src/jbuild.ml
View File

@ -20,71 +20,78 @@ module Jbuild_version = struct
let latest_stable = V1 let latest_stable = V1
end end
let invalid_module_name name sexp = let invalid_module_name =
of_sexp_error sexp (sprintf "invalid module name: %S" name) Parser.errorf "invalid module name: %S"
let module_name sexp = let module_name =
let name = string sexp in Parser.map_validate string ~f:(fun name ->
match name with match name with
| "" -> invalid_module_name name sexp | "" -> invalid_module_name name
| s -> | s ->
(match s.[0] with try
| 'A'..'Z' | 'a'..'z' -> () (match s.[0] with
| _ -> invalid_module_name name sexp); | 'A'..'Z' | 'a'..'z' -> ()
String.iter s ~f:(function | _ -> raise_notrace Exit);
| 'A'..'Z' | 'a'..'z' | '0'..'9' | '\'' | '_' -> () String.iter s ~f:(function
| _ -> invalid_module_name name sexp); | 'A'..'Z' | 'a'..'z' | '0'..'9' | '\'' | '_' -> ()
String.capitalize s | _ -> 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 = let invalid_lib_name = Parser.error "invalid library name"
of_sexp_error sexp "invalid library name"
let library_name sexp = let library_name =
match string sexp with Parser.map_validate string ~f:(function
| "" -> invalid_lib_name sexp | "" -> invalid_lib_name
| s -> | s ->
if s.[0] = '.' then invalid_lib_name sexp; if s.[0] = '.' then invalid_lib_name
String.iter s ~f:(function else
| 'A'..'Z' | 'a'..'z' | '_' | '.' | '0'..'9' -> () try
| _ -> invalid_lib_name sexp); String.iter s ~f:(function
s | 'A'..'Z' | 'a'..'z' | '_' | '.' | '0'..'9' -> ()
| _ -> raise_notrace Exit);
Ok s
with Exit -> invalid_lib_name)
let file sexp = let file =
match string sexp with Parser.map_validate string ~f:(function
| "." | ".." -> | "." | ".." -> Parser.error "'.' and '..' are not valid filenames"
of_sexp_error sexp "'.' and '..' are not valid filenames" | fn -> Ok fn)
| fn -> fn
let file_in_current_dir sexp = let file_in_current_dir =
match string sexp with Parser.map_validate string ~f:(function
| "." | ".." ->
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 relative_file sexp = | "." | ".." -> Parser.error "'.' and '..' are not valid filenames"
let fn = file sexp in | fn ->
if not (Filename.is_relative fn) then if Filename.dirname fn <> Filename.current_dir_name then
of_sexp_error sexp "relative filename expected"; Parser.error "file in current directory expected"
fn 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 c_name, cxx_name =
let make what ext sexp = let make what ext =
let s = string sexp in Parser.map_validate string ~f:(fun s ->
if match s with if match s with
| "" | "." | ".." -> true | "" | "." | ".." -> true
| _ -> Filename.basename s <> s then | _ -> Filename.basename s <> s then
of_sexp_errorf sexp Parser.errorf
"%S is not a valid %s name.\n\ "%S is not a valid %s name.\n\
Hint: To use %s files from another directory, use a \ Hint: To use %s files from another directory, use a \
(copy_files <dir>/*.%s) stanza instead." (copy_files <dir>/*.%s) stanza instead."
s what what ext s what what ext
else else
s Ok s)
in in
(make "C" "c", (make "C" "c",
make "C++" "cpp") make "C++" "cpp")
@ -144,10 +151,12 @@ module Pkg = struct
(hint name_s (Package.Name.Map.keys project.packages (hint name_s (Package.Name.Map.keys project.packages
|> List.map ~f:Package.Name.to_string))) |> List.map ~f:Package.Name.to_string)))
let t p sexp = let t p =
match resolve p (Package.Name.of_string (string sexp)) with let open Parser.O in
| Ok p -> p Package.Name.t >>= fun name ->
| Error s -> Loc.fail (Sexp.Ast.loc sexp) "%s" s match resolve p name with
| Ok x -> Parser.return x
| Error e -> Parser.fail "%s" e
let field p = let field p =
map_validate (field_o "package" string) ~f:(function map_validate (field_o "package" string) ~f:(function
@ -183,9 +192,9 @@ module Pp_or_flags = struct
else else
PP (loc, Pp.of_string s) 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 | 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 split l =
let pps, flags = let pps, flags =
@ -219,10 +228,10 @@ module Dep_conf = struct
; "universe" , return Universe ; "universe" , return Universe
] ]
in in
fun sexp -> Sexp.Of_sexp.make (fun sexp ->
match sexp with match sexp with
| Atom _ | Quoted_string _ -> File (String_with_vars.t sexp) | Atom _ | Quoted_string _ -> File (parse String_with_vars.t sexp)
| List _ -> t sexp | List _ -> parse t sexp)
open Sexp open Sexp
let sexp_of_t = function let sexp_of_t = function
@ -274,20 +283,20 @@ end
module Per_module = struct module Per_module = struct
include Per_item.Make(Module.Name) include Per_item.Make(Module.Name)
let t ~default a sexp = let t ~default a = Sexp.Of_sexp.make (fun sexp ->
match sexp with match sexp with
| List (_, Atom (_, A "per_module") :: rest) -> begin | List (_, Atom (_, A "per_module") :: rest) -> begin
List.map rest ~f:(fun sexp -> List.map rest ~f:(fun sexp ->
let pp, names = pair a module_names sexp in let pp, names = parse (pair a module_names) sexp in
(List.map ~f:Module.Name.of_string (String.Set.to_list names), pp)) (List.map ~f:Module.Name.of_string (String.Set.to_list names), pp))
|> of_mapping ~default |> of_mapping ~default
|> function |> function
| Ok t -> t | Ok t -> t
| Error (name, _, _) -> | Error (name, _, _) ->
of_sexp_error sexp (sprintf "module %s present in two different sets" of_sexp_error sexp (sprintf "module %s present in two different sets"
(Module.Name.to_string name)) (Module.Name.to_string name))
end end
| sexp -> for_all (a sexp) | sexp -> for_all (parse a sexp))
end end
module Preprocess_map = struct module Preprocess_map = struct
@ -368,7 +377,7 @@ module Lib_dep = struct
name); name);
{ required { required
; forbidden ; forbidden
; file = file fsexp ; file = parse file fsexp
} }
| Atom (_, A "->") :: _ | Atom (_, A "->") :: _
| List _ :: _ | [] -> | List _ :: _ | [] ->
@ -384,16 +393,16 @@ module Lib_dep = struct
loop String.Set.empty String.Set.empty l loop String.Set.empty String.Set.empty l
| sexp -> of_sexp_error sexp "(<library-name> <code>) expected" | 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) -> | Atom (loc, A s) | Quoted_string (loc, s) ->
Direct (loc, s) Direct (loc, s)
| List (loc, Atom (_, A "select") :: m :: Atom (_, A "from") :: libs) -> | 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 ; choices = List.map libs ~f:choice
; loc ; loc
} }
| sexp -> | 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 let to_lib_names = function
| Direct (_, s) -> [s] | Direct (_, s) -> [s]
@ -415,8 +424,8 @@ module Lib_deps = struct
| Optional | Optional
| Forbidden | Forbidden
let t sexp = let t = Sexp.Of_sexp.make (fun sexp ->
let t = list Lib_dep.t sexp in let t = parse (list Lib_dep.t) sexp in
let add kind name acc = let add kind name acc =
match String.Map.find acc name with match String.Map.find acc name with
| None -> String.Map.add acc name kind | 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 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))) String.Set.fold c.forbidden ~init:acc ~f:(add Forbidden)))
: kind String.Map.t); : kind String.Map.t);
t t)
let of_pps pps = let of_pps pps =
List.map pps ~f:(fun pp -> Lib_dep.of_pp (Loc.none, pp)) List.map pps ~f:(fun pp -> Lib_dep.of_pp (Loc.none, pp))
@ -623,7 +632,7 @@ module Mode_conf = struct
module Set = struct module Set = struct
include Set.Make(T) 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] 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 "self_build_stubs_archive" (option string) ~default:None >>= fun self_build_stubs_archive ->
field_b "no_dynlink" >>= fun no_dynlink -> field_b "no_dynlink" >>= fun no_dynlink ->
Sub_system_info.record_parser () >>= fun sub_systems -> Sub_system_info.record_parser () >>= fun sub_systems ->
field "ppx.driver" ignore ~default:() >>= fun () -> field "ppx.driver" discard ~default:() >>= fun () ->
return return
{ name { name
; public ; public
@ -747,14 +756,13 @@ module Install_conf = struct
; dst : string option ; dst : string option
} }
let file sexp = let file = Sexp.Of_sexp.make (function
match sexp with
| Atom (_, A src) -> { src; dst = None } | Atom (_, A src) -> { src; dst = None }
| List (_, [Atom (_, A src); Atom (_, A "as"); Atom (_, A dst)]) -> | List (_, [Atom (_, A src); Atom (_, A "as"); Atom (_, A dst)]) ->
{ src; dst = Some dst } { src; dst = Some dst }
| _ -> | sexp ->
of_sexp_error 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 = type t =
{ section : Install.Section.t { section : Install.Section.t
@ -822,12 +830,12 @@ module Executables = struct
let simple = let simple =
Sexp.Of_sexp.enum simple_representations Sexp.Of_sexp.enum simple_representations
let t sexp = let t = Sexp.Of_sexp.make (fun sexp ->
match sexp with match sexp with
| List _ -> | 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 } { mode; kind }
| _ -> simple sexp | _ -> parse simple sexp)
let simple_sexp_of_t link_mode = let simple_sexp_of_t link_mode =
let is_ok (_, candidate) = let is_ok (_, candidate) =
@ -847,19 +855,19 @@ module Executables = struct
module Set = struct module Set = struct
include Set.Make(T) include Set.Make(T)
let t sexp : t = let t =
match list t sexp with Parser.map_validate (list t) ~f:(function
| [] -> of_sexp_error sexp "No linking mode defined" | [] -> Parser.error "No linking mode defined"
| l -> | l ->
let t = of_list l in let t = of_list l in
if (mem t native_exe && mem t exe ) || if (mem t native_exe && mem t exe ) ||
(mem t native_object && mem t object_ ) || (mem t native_object && mem t object_ ) ||
(mem t native_shared_object && mem t shared_object) then (mem t native_shared_object && mem t shared_object) then
of_sexp_error sexp Parser.error
"It is not allowed use both native and best \ "It is not allowed use both native and best \
for the same binary kind." for the same binary kind."
else else
t Ok t)
let default = let default =
of_list of_list
@ -894,7 +902,8 @@ module Executables = struct
field "modes" Link_mode.Set.t ~default:Link_mode.Set.default field "modes" Link_mode.Set.t ~default:Link_mode.Set.default
>>= fun modes -> >>= fun modes ->
map_validate 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 ~f:(function
| false -> Ok () | false -> Ok ()
| true -> | true ->
@ -944,7 +953,7 @@ module Executables = struct
in in
match to_install with match to_install with
| [] -> | [] ->
(field_o "package" Sexp.Ast.loc >>= function (field_o "package" loc >>= function
| None -> return (t, None) | None -> return (t, None)
| Some loc -> | Some loc ->
Loc.warn loc Loc.warn loc
@ -955,10 +964,10 @@ module Executables = struct
Pkg.field project >>= fun package -> Pkg.field project >>= fun package ->
return (t, Some { Install_conf. section = Bin; files; package }) return (t, Some { Install_conf. section = Bin; files; package })
let public_name sexp = let public_name =
match string sexp with Parser.map string ~f:(function
| "-" -> None | "-" -> None
| s -> Some s | s -> Some s)
let multi ~syntax project = let multi ~syntax project =
record record
@ -1018,63 +1027,64 @@ module Rule = struct
; loc : Loc.t ; loc : Loc.t
} }
let v1 sexp = let v1 = Sexp.Of_sexp.make (fun sexp ->
let loc = Sexp.Ast.loc sexp in let loc = Sexp.Ast.loc sexp in
match sexp with match sexp with
| List (loc, (Atom _ :: _)) -> | List (loc, (Atom _ :: _)) ->
{ targets = Infer { targets = Infer
; deps = [] ; deps = []
; action = (loc, Action.Unexpanded.t sexp) ; action = (loc, parse Action.Unexpanded.t sexp)
; mode = Standard ; mode = Standard
; locks = [] ; locks = []
; loc = loc ; loc = loc
} }
| _ -> | _ ->
record parse (
(field "targets" (list file_in_current_dir) >>= fun targets -> record
field "deps" (list Dep_conf.t) ~default:[] >>= fun deps -> (field "targets" (list file_in_current_dir) >>= fun targets ->
field "action" (located Action.Unexpanded.t) >>= fun action -> field "deps" (list Dep_conf.t) ~default:[] >>= fun deps ->
field "locks" (list String_with_vars.t) ~default:[] >>= fun locks -> field "action" (located Action.Unexpanded.t) >>= fun action ->
map_validate field "locks" (list String_with_vars.t) ~default:[] >>= fun locks ->
(field_b "fallback" >>= fun fallback -> map_validate
field_o "mode" Mode.t >>= fun mode -> (field_b "fallback" >>= fun fallback ->
return (fallback, mode)) field_o "mode" Mode.t >>= fun mode ->
~f:(function return (fallback, mode))
| true, Some _ -> ~f:(function
Error "Cannot use both (fallback) and (mode ...) at the \ | true, Some _ ->
same time.\n\ Error "Cannot use both (fallback) and (mode ...) at the \
(fallback) is the same as (mode fallback), \ same time.\n\
please use the latter in new code." (fallback) is the same as (mode fallback), \
| false, Some mode -> Ok mode please use the latter in new code."
| true, None -> Ok Fallback | false, Some mode -> Ok mode
| false, None -> Ok Standard) | true, None -> Ok Fallback
>>= fun mode -> | false, None -> Ok Standard)
return { targets = Static targets >>= fun mode ->
; deps return { targets = Static targets
; action ; deps
; mode ; action
; locks ; mode
; loc ; locks
}) ; loc
sexp }))
sexp)
type lex_or_yacc = type lex_or_yacc =
{ modules : string list { modules : string list
; mode : Mode.t ; mode : Mode.t
} }
let ocamllex_v1 sexp = let ocamllex_v1 = Sexp.Of_sexp.make (fun sexp ->
match sexp with match sexp with
| List (_, List (_, _) :: _) -> | List (_, List (_, _) :: _) ->
record parse (
(field "modules" (list string) >>= fun modules -> record
Mode.field >>= fun mode -> (field "modules" (list string) >>= fun modules ->
return { modules; mode }) Mode.field >>= fun mode ->
sexp return { modules; mode })) sexp
| _ -> | _ ->
{ modules = list string sexp { modules = parse (list string) sexp
; mode = Standard ; mode = Standard
} })
let ocamlyacc_v1 = ocamllex_v1 let ocamlyacc_v1 = ocamllex_v1
@ -1152,12 +1162,12 @@ module Alias_conf = struct
; package : Package.t option ; package : Package.t option
} }
let alias_name sexp = let alias_name =
let s = string sexp in Parser.map_validate string ~f:(fun s ->
if Filename.basename s <> s then if Filename.basename s <> s then
of_sexp_errorf sexp "%S is not a valid alias name" s Parser.errorf "%S is not a valid alias name" s
else else
s Ok s)
let v1 project = let v1 project =
record record
@ -1224,17 +1234,17 @@ module Env = struct
field_oslu "ocamlopt_flags" >>= fun ocamlopt_flags -> field_oslu "ocamlopt_flags" >>= fun ocamlopt_flags ->
return { flags; ocamlc_flags; ocamlopt_flags }) return { flags; ocamlc_flags; ocamlopt_flags })
let rule = function let rule = Sexp.Of_sexp.make (function
| List (loc, Atom (_, A pat) :: fields) -> | List (loc, Atom (_, A pat) :: fields) ->
let pat = let pat =
match pat with match pat with
| "_" -> Any | "_" -> Any
| s -> Profile s | s -> Profile s
in in
(pat, config (List (loc, fields))) (pat, parse config (List (loc, fields)))
| sexp -> | sexp ->
of_sexp_error sexp of_sexp_error sexp
"S-expression of the form (<profile> <fields>) expected" "S-expression of the form (<profile> <fields>) expected")
end end
type Stanza.t += type Stanza.t +=
@ -1329,7 +1339,7 @@ module Stanzas = struct
exception Include_loop of Path.t * (Loc.t * Path.t) list exception Include_loop of Path.t * (Loc.t * Path.t) list
let rec parse stanza_parser ~current_file ~include_stack sexps = 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 |> List.concat_map ~f:(function
| Include (loc, fn) -> | Include (loc, fn) ->
let include_stack = (loc, current_file) :: include_stack in let include_stack = (loc, current_file) :: include_stack in

2
src/mode.ml
View File

@ -73,7 +73,7 @@ module Dict = struct
; native = List.mem Native ~set:l ; 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) let is_empty t = not (t.byte || t.native)

15
src/ordered_set_lang.ml
View File

@ -40,7 +40,7 @@ let parse_general sexp ~f =
in in
of_sexp sexp of_sexp sexp
let t sexp : t = let t = Sexp.Of_sexp.make (fun sexp ->
let ast = let ast =
parse_general sexp ~f:(function parse_general sexp ~f:(function
| Atom (loc, A s) | Quoted_string (loc, s) -> (loc, s) | Atom (loc, A s) | Quoted_string (loc, s) -> (loc, s)
@ -48,7 +48,7 @@ let t sexp : t =
in in
{ ast { ast
; loc = Some (Sexp.Ast.loc sexp) ; loc = Some (Sexp.Ast.loc sexp)
} })
let is_standard t = let is_standard t =
match (t.ast : ast_expanded) with match (t.ast : ast_expanded) with
@ -171,13 +171,13 @@ let standard =
module Unexpanded = struct module Unexpanded = struct
type ast = (Sexp.Ast.t, Ast.unexpanded) Ast.t type ast = (Sexp.Ast.t, Ast.unexpanded) Ast.t
type t = ast generic 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 rec map (t : (Sexp.Ast.t, Ast.expanded) Ast.t) =
let open Ast in let open Ast in
match t with match t with
| Element x -> Element x | Element x -> Element x
| Union [Special (_, "include"); Element fn] -> | 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"); _] | Union [Special (loc, "include"); _]
| Special (loc, "include") -> | Special (loc, "include") ->
Loc.fail loc "(:include expects a single element (do you need to quote the filename?)" Loc.fail loc "(:include expects a single element (do you need to quote the filename?)"
@ -189,7 +189,7 @@ module Unexpanded = struct
in in
{ ast = map (parse_general sexp ~f:(fun x -> x)) { ast = map (parse_general sexp ~f:(fun x -> x))
; loc = Some (Sexp.Ast.loc sexp) ; loc = Some (Sexp.Ast.loc sexp)
} })
let sexp_of_t t = let sexp_of_t t =
let open Ast in let open Ast in
@ -241,7 +241,8 @@ module Unexpanded = struct
let rec expand (t : ast) : ast_expanded = let rec expand (t : ast) : ast_expanded =
let open Ast in let open Ast in
match t with 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) | Special (l, s) -> Special (l, s)
| Include fn -> | Include fn ->
let sexp = let sexp =
@ -257,7 +258,7 @@ module Unexpanded = struct
] ]
in in
parse_general sexp ~f:(fun sexp -> 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) | Union l -> Union (List.map l ~f:expand)
| Diff (l, r) -> | Diff (l, r) ->
Diff (expand l, expand r) Diff (expand l, expand r)

2
src/package.ml
View File

@ -12,6 +12,8 @@ module Name = struct
let opam_fn (t : t) = to_string t ^ ".opam" let opam_fn (t : t) = to_string t ^ ".opam"
let pp fmt t = Format.pp_print_string fmt (to_string t) let pp fmt t = Format.pp_print_string fmt (to_string t)
let t = Sexp.Of_sexp.(Parser.map ~f:of_string string)
end end

2
src/package.mli
View File

@ -12,6 +12,8 @@ module Name : sig
val pp : Format.formatter -> t -> unit val pp : Format.formatter -> t -> unit
include Interned.S with type t := t include Interned.S with type t := t
val t : t Sexp.Of_sexp.t
end end
type t = type t =

2
src/preprocessing.ml
View File

@ -188,7 +188,7 @@ module Jbuild_driver = struct
let make name info : (Pp.t * Driver.t) Lazy.t = lazy ( let make name info : (Pp.t * Driver.t) Lazy.t = lazy (
let info = let info =
Sexp.parse_string ~mode:Single ~fname:"<internal>" info Sexp.parse_string ~mode:Single ~fname:"<internal>" info
|> Driver.Info.parse |> Sexp.Of_sexp.parse Driver.Info.parse
in in
(Pp.of_string name, (Pp.of_string name,
{ info { info

43
src/stdune/path.ml
View File

@ -70,11 +70,12 @@ end = struct
make t make t
let sexp_of_t t = Sexp.To_sexp.string (to_string t) let sexp_of_t t = Sexp.To_sexp.string (to_string t)
let t sexp = let t = Sexp.Of_sexp.(
let t = Sexp.Of_sexp.string sexp in Parser.map_validate string ~f:(fun t ->
if Filename.is_relative t then if Filename.is_relative t then
Sexp.Of_sexp.of_sexp_error sexp "Absolute path expected"; Parser.error "Absolute path expected"
of_string t else
Ok (of_string t)))
(* (*
let rec cd_dot_dot t = let rec cd_dot_dot t =
@ -276,9 +277,9 @@ end = struct
| _ -> | _ ->
relative root s ?error_loc relative root s ?error_loc
let t sexp = let t = Sexp.Of_sexp.(
of_string (Sexp.Of_sexp.string sexp) Parser.map (located string) ~f:(fun (error_loc, s) ->
~error_loc:(Sexp.Ast.loc sexp) of_string s ~error_loc))
let rec mkdir_p t = let rec mkdir_p t =
if is_root t then if is_root t then
@ -587,18 +588,20 @@ let of_string ?error_loc s =
else else
make_local_path (Local.of_string s ?error_loc) make_local_path (Local.of_string s ?error_loc)
let t = function let t =
(* the first 2 cases are necessary for old build dirs *) Sexp.Of_sexp.make (function
| Sexp.Ast.Atom (_, A s) (* the first 2 cases are necessary for old build dirs *)
| Quoted_string (_, s) -> of_string s | Sexp.Ast.Atom (_, A s)
| s -> | Quoted_string (_, s) -> of_string s
let open Sexp.Of_sexp in | s ->
sum let open Sexp.Of_sexp in
[ "In_build_dir" , next Local.t >>| in_build_dir parse (
; "In_source_tree", next Local.t >>| in_source_tree sum
; "External" , next External.t >>| external_ [ "In_build_dir" , next Local.t >>| in_build_dir
] ; "In_source_tree", next Local.t >>| in_source_tree
s ; "External" , next External.t >>| external_
])
s)
let sexp_of_t t = let sexp_of_t t =
let constr f x y = Sexp.To_sexp.(pair string f) (x, y) in let constr f x y = Sexp.To_sexp.(pair string f) (x, y) in

2
src/stdune/result.ml
View File

@ -2,6 +2,8 @@ type ('a, 'error) t = ('a, 'error) Caml.result =
| Ok of 'a | Ok of 'a
| Error of 'error | Error of 'error
let ok x = Ok x
let is_ok = function let is_ok = function
| Ok _ -> true | Ok _ -> true
| Error _ -> false | Error _ -> false

2
src/stdune/result.mli
View File

@ -4,6 +4,8 @@ type ('a, 'error) t = ('a, 'error) Caml.result =
| Ok of 'a | Ok of 'a
| Error of 'error | Error of 'error
val ok : 'a -> ('a, _) t
val is_ok : _ t -> bool val is_ok : _ t -> bool
val is_error : _ t -> bool val is_error : _ t -> bool

37
src/stdune/sexp.ml
View File

@ -74,12 +74,47 @@ module Of_sexp = struct
type 'a t = ast -> 'a 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 = let located f sexp =
(Ast.loc sexp, 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_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 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 = let of_sexp_errorf_loc ?hint loc fmt =
Printf.ksprintf (fun s -> raise (Of_sexp (loc, s, hint))) fmt Printf.ksprintf (fun s -> raise (Of_sexp (loc, s, hint))) fmt
@ -89,6 +124,8 @@ module Of_sexp = struct
| List (_, []) -> () | List (_, []) -> ()
| sexp -> of_sexp_error sexp "() expected" | sexp -> of_sexp_error sexp "() expected"
let discard (_ : ast) = ()
let string = function let string = function
| Atom (_, A s) -> s | Atom (_, A s) -> s
| Quoted_string (_, s) -> s | Quoted_string (_, s) -> s

31
src/stdune/sexp.mli
View File

@ -65,13 +65,42 @@ module Of_sexp : sig
exception Of_sexp of Loc.t * string * hint option 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_error : ?hint:hint -> Ast.t -> string -> _
val of_sexp_errorf : ?hint:hint -> Ast.t -> ('a, unit, string, 'b) format4 -> 'a val of_sexp_errorf : ?hint:hint -> Ast.t -> ('a, unit, string, 'b) format4 -> 'a
val located : 'a t -> (Loc.t * 'a) t val located : 'a t -> (Loc.t * 'a) t
val loc : Loc.t t
val raw : ast t val raw : ast t
val enum : (string * 'a) list -> 'a t val enum : (string * 'a) list -> 'a t

11
src/string_with_vars.ml
View File

@ -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 items_of_string s = of_tokens (Token.tokenise s)
let t : Sexp.Of_sexp.ast -> t = function let t =
| Atom(loc, A s) -> { items = items_of_string s; loc; quoted = false } Sexp.Of_sexp.make (function
| Quoted_string (loc, s) -> | Atom(loc, A s) -> { items = items_of_string s; loc; quoted = false }
{ items = items_of_string s; loc; quoted = true } | Quoted_string (loc, s) ->
| List _ as sexp -> Sexp.Of_sexp.of_sexp_error sexp "Atom expected" { 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 let loc t = t.loc

4
src/syntax.ml
View File

@ -7,7 +7,7 @@ module Version = struct
let sexp_of_t t = Sexp.unsafe_atom_of_string (to_string t) 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 | Atom (loc, A s) -> begin
try try
Scanf.sscanf s "%u.%u" (fun a b -> (a, b)) 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" Loc.fail loc "atom of the form NNN.NNN expected"
end end
| sexp -> | 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) = let can_read ~parser_version:(pa, pb) ~data_version:(da, db) =
pa = da && db <= pb pa = da && db <= pb

2
src/vfile_kind.ml
View File

@ -66,7 +66,7 @@ module Make
struct struct
module Of_sexp = struct module Of_sexp = struct
include F(Sexp.Of_sexp) include F(Sexp.Of_sexp)
let t _ sexp = t sexp let t _ sexp = Sexp.Of_sexp.parse t sexp
end end
module To_sexp = struct module To_sexp = struct
include F(Sexp.To_sexp) include F(Sexp.To_sexp)

36
src/workspace.ml
View File

@ -7,10 +7,10 @@ module Context = struct
| Native | Native
| Named of string | Named of string
let t sexp = let t =
match string sexp with Parser.map string ~f:(function
| "native" -> Native | "native" -> Native
| s -> Named s | s -> Named s)
end end
module Opam = struct module Opam = struct
@ -55,22 +55,24 @@ module Context = struct
type t = Default of Default.t | Opam of Opam.t 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") -> | Atom (_, A "default") ->
Default { targets = [Native] Default { targets = [Native]
; profile ; 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 -> | sexp ->
sum Sexp.Of_sexp.parse
[ "default", (sum
(rest_as_record (Default.t ~profile) >>| fun x -> [ "default",
Default x) (rest_as_record (Default.t ~profile) >>| fun x ->
; "opam", Default x)
(rest_as_record (Opam.t ~profile) >>| fun x -> ; "opam",
Opam x) (rest_as_record (Opam.t ~profile) >>| fun x ->
] Opam x)
sexp ])
sexp)
let name = function let name = function
| Default _ -> "default" | Default _ -> "default"
@ -107,7 +109,7 @@ let t ?x ?profile:cmdline_profile sexps =
let defined_names = ref String.Set.empty in let defined_names = ref String.Set.empty in
let profiles, contexts = let profiles, contexts =
List.partition_map sexps ~f:(fun sexp -> 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) | Profile (loc, p) -> Left (loc, p)
| Context c -> Right c) | Context c -> Right c)
in in
@ -126,7 +128,7 @@ let t ?x ?profile:cmdline_profile sexps =
} }
in in
List.fold_left contexts ~init ~f:(fun t sexp -> 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 = let ctx =
match x with match x with
| None -> ctx | None -> ctx

3
test/unit-tests/jbuild.mlt
View File

@ -1,3 +1,4 @@
(* -*- tuareg -*- *)
open Dune;; open Dune;;
open Stdune;; open Stdune;;
@ -7,7 +8,7 @@ open Stdune;;
(* Jbuild.Executables.Link_mode.t *) (* Jbuild.Executables.Link_mode.t *)
let test s = 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) (Sexp.parse_string ~fname:"" ~mode:Sexp.Parser.Mode.Single s)
[%%expect{| [%%expect{|
val test : string -> Dune.Jbuild.Executables.Link_mode.t = <fun> val test : string -> Dune.Jbuild.Executables.Link_mode.t = <fun>

8
test/unit-tests/sexp.mlt
View File

@ -24,18 +24,18 @@ val sexp : Usexp.Ast.t = ((foo 1) (foo 2))
|}] |}]
let of_sexp = record (field "foo" int) let of_sexp = record (field "foo" int)
let x = of_sexp sexp let x = parse of_sexp sexp
[%%expect{| [%%expect{|
val of_sexp : int Stdune.Sexp.Of_sexp.t = <fun> val of_sexp : int Stdune.Sexp.Of_sexp.t = <abstr>
Exception: Exception:
Stdune__Sexp.Of_sexp.Of_sexp (<abstr>, Stdune__Sexp.Of_sexp.Of_sexp (<abstr>,
"Field \"foo\" is present too many times", None). "Field \"foo\" is present too many times", None).
|}] |}]
let of_sexp = record (dup_field "foo" int) let of_sexp = record (dup_field "foo" int)
let x = of_sexp sexp let x = parse of_sexp sexp
[%%expect{| [%%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] val x : int list = [1; 2]
|}] |}]