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
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
[]

4
src/build_system.ml
View File

@ -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

11
src/config.ml
View File

@ -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

2
src/context.ml
View File

@ -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

24
src/dune_project.ml
View File

@ -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

22
src/file_tree.ml
View File

@ -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 =

15
src/installed_dune_file.ml
View File

@ -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
View File

@ -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

2
src/mode.ml
View File

@ -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)

15
src/ordered_set_lang.ml
View File

@ -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)

2
src/package.ml
View File

@ -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

2
src/package.mli
View File

@ -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 =

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 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

43
src/stdune/path.ml
View File

@ -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
src/stdune/result.ml
View File

@ -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

2
src/stdune/result.mli
View File

@ -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

37
src/stdune/sexp.ml
View File

@ -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

31
src/stdune/sexp.mli
View File

@ -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

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 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

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 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

2
src/vfile_kind.ml
View File

@ -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)

36
src/workspace.ml
View File

@ -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

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

@ -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>

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 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]
|}]