diff --git a/bin/main.ml b/bin/main.ml index f73e5517..2cd5a674 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -1,3 +1,4 @@ +open! Stdune open Dune open Import open Cmdliner @@ -985,11 +986,11 @@ let rules = in Build_system.build_rules setup.build_system ~request ~recursive >>= fun rules -> let sexp_of_action action = - Action.for_shell action |> Action.For_shell.sexp_of_t + Action.for_shell action |> Action.For_shell.dgen in let print oc = let ppf = Format.formatter_of_out_channel oc in - Sexp.prepare_formatter ppf; + Dsexp.prepare_formatter ppf; Format.pp_open_vbox ppf 0; if makefile_syntax then begin List.iter rules ~f:(fun (rule : Build_system.Rule.t) -> @@ -1000,25 +1001,25 @@ let rules = (fun ppf -> Path.Set.iter rule.deps ~f:(fun dep -> Format.fprintf ppf "@ %s" (Path.to_string dep))) - Sexp.pp_split_strings (sexp_of_action rule.action)) + Dsexp.pp_split_strings (sexp_of_action rule.action)) end else begin List.iter rules ~f:(fun (rule : Build_system.Rule.t) -> let sexp = let paths ps = - Sexp.To_sexp.list Path.sexp_of_t (Path.Set.to_list ps) + Dsexp.To_sexp.list Path_dsexp.dgen (Path.Set.to_list ps) in - Sexp.To_sexp.record ( + Dsexp.To_sexp.record ( List.concat [ [ "deps" , paths rule.deps ; "targets", paths rule.targets ] ; (match rule.context with | None -> [] | Some c -> ["context", - Sexp.atom_or_quoted_string c.name]) + Dsexp.atom_or_quoted_string c.name]) ; [ "action" , sexp_of_action rule.action ] ]) in - Format.fprintf ppf "%a@," Sexp.pp_split_strings sexp) + Format.fprintf ppf "%a@," Dsexp.pp_split_strings sexp) end; Format.pp_print_flush ppf (); Fiber.return () @@ -1472,7 +1473,7 @@ let printenv = Build_system.do_build setup.build_system ~request >>| fun l -> let pp ppf = Format.fprintf ppf "@[(@,@[%a@]@]@,)" - (Format.pp_print_list (Sexp.pp Dune)) in + (Format.pp_print_list (Dsexp.pp Dune)) in match l with | [(_, env)] -> Format.printf "%a@." pp env diff --git a/bootstrap.ml b/bootstrap.ml index bc18be1e..269cc07f 100644 --- a/bootstrap.ml +++ b/bootstrap.ml @@ -36,7 +36,7 @@ let dirs = ; "src/xdg" , Some "Xdg" ; "src/ocaml-config" , Some "Ocaml_config" ; "vendor/boot" , None - ; "src/usexp" , Some "Usexp" + ; "src/dsexp" , Some "Dsexp" ; "src" , None ] diff --git a/src/action.ml b/src/action.ml index 0eaee018..880de4fe 100644 --- a/src/action.ml +++ b/src/action.ml @@ -1,5 +1,6 @@ +open! Stdune open Import -open Sexp.Of_sexp +open Dsexp.Of_sexp let ignore_loc k ~loc:_ = k @@ -15,9 +16,9 @@ end module Diff_mode = Action_intf.Diff_mode module Make_ast - (Program : Sexp.Sexpable) - (Path : Sexp.Sexpable) - (String : Sexp.Sexpable) + (Program : Dsexp.Sexpable) + (Path : Dsexp.Sexpable) + (String : Dsexp.Sexpable) (Ast : Action_intf.Ast with type program := Program.t with type path := Path.t @@ -25,13 +26,13 @@ module Make_ast struct include Ast - let t = - let path = Path.t and string = String.t in - Sexp.Of_sexp.fix (fun t -> + let dparse = + let path = Path.dparse and string = String.dparse in + Dsexp.Of_sexp.fix (fun t -> sum [ "run", - (let%map prog = Program.t - and args = repeat string + (let%map prog = Program.dparse + and args = repeat String.dparse in Run (prog, args)) ; "chdir", @@ -129,55 +130,53 @@ struct Diff { optional = false; file1; file2; mode = Binary }) ]) - let rec sexp_of_t : _ -> Sexp.t = - let path = Path.sexp_of_t and string = String.sexp_of_t in + let rec dgen = + let open Dsexp in + let program = Program.dgen in + let string = String.dgen in + let path = Path.dgen in function - | Run (a, xs) -> List (Sexp.unsafe_atom_of_string "run" - :: Program.sexp_of_t a :: List.map xs ~f:string) - | Chdir (a, r) -> List [Sexp.unsafe_atom_of_string "chdir" ; - path a ; sexp_of_t r] - | Setenv (k, v, r) -> List [Sexp.unsafe_atom_of_string "setenv" ; - string k ; string v ; sexp_of_t r] + | Run (a, xs) -> + List (atom "run" :: program a :: List.map xs ~f:string) + | Chdir (a, r) -> List [atom "chdir" ; path a ; dgen r] + | Setenv (k, v, r) -> List [atom "setenv" ; string k ; string v ; dgen r] | Redirect (outputs, fn, r) -> - List [ Sexp.atom (sprintf "with-%s-to" (Outputs.to_string outputs)) + List [ atom (sprintf "with-%s-to" (Outputs.to_string outputs)) ; path fn - ; sexp_of_t r + ; dgen r ] | Ignore (outputs, r) -> - List [ Sexp.atom (sprintf "ignore-%s" (Outputs.to_string outputs)) - ; sexp_of_t r + List [ atom (sprintf "ignore-%s" (Outputs.to_string outputs)) + ; dgen r ] - | Progn l -> List (Sexp.unsafe_atom_of_string "progn" - :: List.map l ~f:sexp_of_t) + | Progn l -> List (atom "progn" :: List.map l ~f:dgen) | Echo xs -> - List (Sexp.unsafe_atom_of_string "echo" :: List.map xs ~f:string) - | Cat x -> List [Sexp.unsafe_atom_of_string "cat"; path x] + List (atom "echo" :: List.map xs ~f:string) + | Cat x -> List [atom "cat"; path x] | Copy (x, y) -> - List [Sexp.unsafe_atom_of_string "copy"; path x; path y] + List [atom "copy"; path x; path y] | Symlink (x, y) -> - List [Sexp.unsafe_atom_of_string "symlink"; path x; path y] + List [atom "symlink"; path x; path y] | Copy_and_add_line_directive (x, y) -> - List [Sexp.unsafe_atom_of_string "copy#"; path x; path y] - | System x -> List [Sexp.unsafe_atom_of_string "system"; string x] - | Bash x -> List [Sexp.unsafe_atom_of_string "bash"; string x] - | Write_file (x, y) -> List [Sexp.unsafe_atom_of_string "write-file"; - path x; string y] - | Rename (x, y) -> List [Sexp.unsafe_atom_of_string "rename"; - path x; path y] - | Remove_tree x -> List [Sexp.unsafe_atom_of_string "remove-tree"; path x] - | Mkdir x -> List [Sexp.unsafe_atom_of_string "mkdir"; path x] - | Digest_files paths -> List [Sexp.unsafe_atom_of_string "digest-files"; + List [atom "copy#"; path x; path y] + | System x -> List [atom "system"; string x] + | Bash x -> List [atom "bash"; string x] + | Write_file (x, y) -> List [atom "write-file"; path x; string y] + | Rename (x, y) -> List [atom "rename"; path x; path y] + | Remove_tree x -> List [atom "remove-tree"; path x] + | Mkdir x -> List [atom "mkdir"; path x] + | Digest_files paths -> List [atom "digest-files"; List (List.map paths ~f:path)] | Diff { optional; file1; file2; mode = Binary} -> assert (not optional); - List [Sexp.unsafe_atom_of_string "cmp"; path file1; path file2] + List [atom "cmp"; path file1; path file2] | Diff { optional = false; file1; file2; mode = _ } -> - List [Sexp.unsafe_atom_of_string "diff"; path file1; path file2] + List [atom "diff"; path file1; path file2] | Diff { optional = true; file1; file2; mode = _ } -> - List [Sexp.unsafe_atom_of_string "diff?"; path file1; path file2] + List [atom "diff?"; path file1; path file2] | Merge_files_into (srcs, extras, target) -> List - [ Sexp.unsafe_atom_of_string "merge-files-into" + [ atom "merge-files-into" ; List (List.map ~f:path srcs) ; List (List.map ~f:string extras) ; path target @@ -268,11 +267,12 @@ module Prog = struct type t = (Path.t, Not_found.t) result - let t : t Sexp.Of_sexp.t = Sexp.Of_sexp.map Path.t ~f:Result.ok + let dparse : t Dsexp.Of_sexp.t = + Dsexp.Of_sexp.map Path_dsexp.dparse ~f:Result.ok - let sexp_of_t = function - | Ok s -> Path.sexp_of_t s - | Error (e : Not_found.t) -> Sexp.To_sexp.string e.program + let dgen = function + | Ok s -> Path_dsexp.dgen s + | Error (e : Not_found.t) -> Dsexp.To_sexp.string e.program end module type Ast = Action_intf.Ast @@ -283,13 +283,13 @@ module rec Ast : Ast = Ast module String_with_sexp = struct type t = string - let t = Sexp.Of_sexp.string - let sexp_of_t = Sexp.To_sexp.string + let dparse = Dsexp.Of_sexp.string + let dgen = Dsexp.To_sexp.string end include Make_ast (Prog) - (Path) + (Path_dsexp) (String_with_sexp) (Ast) @@ -372,9 +372,19 @@ module Unexpanded = struct include Make_ast(String_with_vars)(String_with_vars)(String_with_vars)(Uast) - let t = + module Mapper = Make_mapper(Uast)(Uast) + + let remove_locs = + let no_loc_template = String_with_vars.make_text Loc.none "" in + fun t -> + Mapper.map t ~dir:no_loc_template + ~f_program:(fun ~dir:_ -> String_with_vars.remove_locs) + ~f_path:(fun ~dir:_ -> String_with_vars.remove_locs) + ~f_string:(fun ~dir:_ -> String_with_vars.remove_locs) + + let dparse = if_list - ~then_:t + ~then_:dparse ~else_: (loc >>| fun loc -> of_sexp_errorf @@ -383,11 +393,11 @@ module Unexpanded = struct let check_mkdir loc path = if not (Path.is_managed path) then - Loc.fail loc + Errors.fail loc "(mkdir ...) is not supported for paths outside of the workspace:\n\ \ %a\n" - (Sexp.pp Dune) - (List [Sexp.unsafe_atom_of_string "mkdir"; Path.sexp_of_t path]) + (Dsexp.pp Dune) + (List [Dsexp.unsafe_atom_of_string "mkdir"; Path_dsexp.dgen path]) module Partial = struct module Program = Unresolved.Program @@ -538,7 +548,7 @@ module Unexpanded = struct Chdir (res, partial_expand t ~dir ~map_exe ~f) | Right fn -> let loc = String_with_vars.loc fn in - Loc.fail loc + Errors.fail loc "This directory cannot be evaluated statically.\n\ This is not allowed by dune" end @@ -733,7 +743,7 @@ module Infer = struct match fn with | Left fn -> { acc with targets = Path.Set.add acc.targets fn } | Right sw -> - Loc.fail (String_with_vars.loc sw) + Errors.fail (String_with_vars.loc sw) "Cannot determine this target statically." let ( +< ) acc fn = match fn with diff --git a/src/action.mli b/src/action.mli index 7fc81485..c81dfafd 100644 --- a/src/action.mli +++ b/src/action.mli @@ -1,3 +1,4 @@ +open! Stdune open! Import module Outputs : module type of struct include Action_intf.Outputs end @@ -31,7 +32,7 @@ include Action_intf.Helpers with type string := string with type t := t -val t : t Sexp.Of_sexp.t +val dparse : t Dsexp.Of_sexp.t module For_shell : sig include Action_intf.Ast @@ -39,7 +40,7 @@ module For_shell : sig with type path := string with type string := string - val sexp_of_t : t Sexp.To_sexp.t + val dgen : t Dsexp.To_sexp.t end (** Convert the action to a format suitable for printing *) @@ -72,7 +73,7 @@ module Unexpanded : sig with type path := String_with_vars.t with type string := String_with_vars.t - include Sexp.Sexpable with type t := t + include Dsexp.Sexpable with type t := t module Partial : sig include Action_intf.Ast @@ -94,6 +95,8 @@ module Unexpanded : sig -> map_exe:(Path.t -> Path.t) -> f:(Value.t list option String_with_vars.expander) -> Partial.t + + val remove_locs : t -> t end (** Infer dependencies and targets. diff --git a/src/action_exec.ml b/src/action_exec.ml index d85e5f32..ef25c8c3 100644 --- a/src/action_exec.ml +++ b/src/action_exec.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Fiber.O diff --git a/src/action_exec.mli b/src/action_exec.mli index ebec0af7..ffc2bca9 100644 --- a/src/action_exec.mli +++ b/src/action_exec.mli @@ -1,4 +1,4 @@ -open Stdune +open! Stdune val exec : targets:Path.Set.t diff --git a/src/action_intf.ml b/src/action_intf.ml index 4f4a8c07..3dd7f235 100644 --- a/src/action_intf.ml +++ b/src/action_intf.ml @@ -1,4 +1,4 @@ -open Stdune +open! Stdune module Outputs = struct type t = diff --git a/src/arg_spec.ml b/src/arg_spec.ml index f511a623..b715c8df 100644 --- a/src/arg_spec.ml +++ b/src/arg_spec.ml @@ -1,3 +1,4 @@ +open! Stdune open Import type 'a t = diff --git a/src/arg_spec.mli b/src/arg_spec.mli index 9e40c281..5a396b52 100644 --- a/src/arg_spec.mli +++ b/src/arg_spec.mli @@ -1,3 +1,4 @@ +open! Stdune (** Command line arguments specification *) (** This module implements a small DSL to specify the command line diff --git a/src/artifacts.ml b/src/artifacts.ml index 0875649d..95904317 100644 --- a/src/artifacts.ml +++ b/src/artifacts.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Dune_file diff --git a/src/artifacts.mli b/src/artifacts.mli index b80f0f71..2e551ab0 100644 --- a/src/artifacts.mli +++ b/src/artifacts.mli @@ -1,3 +1,4 @@ +open! Stdune open! Import type t diff --git a/src/bin.ml b/src/bin.ml index 1a1301b7..871c4fb7 100644 --- a/src/bin.ml +++ b/src/bin.ml @@ -1,4 +1,4 @@ -open Import +open! Stdune let path_sep = if Sys.win32 then diff --git a/src/bin.mli b/src/bin.mli index b712ab3e..c73a4ed1 100644 --- a/src/bin.mli +++ b/src/bin.mli @@ -1,6 +1,6 @@ (** OCaml binaries *) -open Stdune +open! Stdune (** Character used to separate entries in [PATH] and similar environment variables *) diff --git a/src/binary_kind.ml b/src/binary_kind.ml index c209eda9..9e037535 100644 --- a/src/binary_kind.ml +++ b/src/binary_kind.ml @@ -1,12 +1,12 @@ -open Stdune +open! Stdune type t = | Exe | Object | Shared_object -let t = - let open Sexp.Of_sexp in +let dparse = + let open Dsexp.Of_sexp in enum [ "exe" , Exe ; "object" , Object @@ -21,7 +21,7 @@ let to_string = function let pp fmt t = Format.pp_print_string fmt (to_string t) -let sexp_of_t t = - Sexp.unsafe_atom_of_string (to_string t) +let dgen t = + Dsexp.unsafe_atom_of_string (to_string t) let all = [Exe; Object; Shared_object] diff --git a/src/binary_kind.mli b/src/binary_kind.mli index b389c80d..d4208cca 100644 --- a/src/binary_kind.mli +++ b/src/binary_kind.mli @@ -1,15 +1,13 @@ (** Linking modes for binaries *) -open Stdune +open! Stdune type t = | Exe | Object | Shared_object -val t : t Sexp.Of_sexp.t - -val sexp_of_t : t Sexp.To_sexp.t +include Dsexp.Sexpable with type t := t val all : t list diff --git a/src/blang.ml b/src/blang.ml index 042d4ce2..0505ee5e 100644 --- a/src/blang.ml +++ b/src/blang.ml @@ -35,7 +35,7 @@ let rec eval_bool t ~dir ~(f : 'a expander) = begin match f.f ~mode:Single a with | _, String "true" -> true | _, String "false" -> false - | loc, _ -> Loc.fail loc "This value must be either true or false" + | loc, _ -> Errors.fail loc "This value must be either true or false" end | And xs -> List.for_all ~f:(eval_bool ~f ~dir) xs | Or xs -> List.exists ~f:(eval_bool ~f ~dir) xs diff --git a/src/blang.mli b/src/blang.mli index 9b9d15c9..3adf276e 100644 --- a/src/blang.mli +++ b/src/blang.mli @@ -1,4 +1,4 @@ -open Stdune +open! Stdune module Op : sig type t = diff --git a/src/build.ml b/src/build.ml index 3904119b..757cfefb 100644 --- a/src/build.ml +++ b/src/build.ml @@ -1,3 +1,4 @@ +open! Stdune open Import module Vspec = struct @@ -59,8 +60,8 @@ module Repr = struct | G_evaluated l -> l | G_unevaluated (loc, path, _) -> Exn.code_error "Build.get_glob_result_exn: got unevaluated" - [ "loc", Loc.sexp_of_t loc - ; "path", Path.sexp_of_t path ] + [ "loc", Loc.to_sexp loc + ; "path", Path.to_sexp path ] end include Repr let repr t = t @@ -130,7 +131,7 @@ let strings p = let read_sexp p syntax = contents p >>^ fun s -> - Usexp.parse_string s + Dsexp.parse_string s ~lexer:(File_tree.Dune_file.Kind.lexer syntax) ~fname:(Path.to_string p) ~mode:Single diff --git a/src/build.mli b/src/build.mli index 4fc9990a..7624ad35 100644 --- a/src/build.mli +++ b/src/build.mli @@ -1,5 +1,6 @@ (** The build arrow *) +open! Stdune open! Import type ('a, 'b) t @@ -95,7 +96,7 @@ val lines_of : Path.t -> ('a, string list) t val strings : Path.t -> ('a, string list) t (** Load an S-expression from a file *) -val read_sexp : Path.t -> Usexp.syntax -> (unit, Sexp.Ast.t) t +val read_sexp : Path.t -> Dsexp.syntax -> (unit, Dsexp.Ast.t) t (** Evaluates to [true] if the file is present on the file system or is the target of a rule. *) diff --git a/src/build_interpret.ml b/src/build_interpret.ml index dda3c677..56dbcd39 100644 --- a/src/build_interpret.ml +++ b/src/build_interpret.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Build.Repr @@ -82,11 +83,11 @@ let static_deps t ~all_targets ~file_tree = if Path.Set.is_empty result then begin match inspect_path file_tree dir with | None -> - Loc.warn loc "Directory %s doesn't exist." + Errors.warn loc "Directory %s doesn't exist." (Path.to_string_maybe_quoted (Path.drop_optional_build_context dir)) | Some Reg -> - Loc.warn loc "%s is not a directory." + Errors.warn loc "%s is not a directory." (Path.to_string_maybe_quoted (Path.drop_optional_build_context dir)) | Some Dir -> @@ -187,7 +188,7 @@ let targets = match loop a [], loop b [] with | [], [] -> acc | a, b -> - let targets x = Path.Set.sexp_of_t (Target.paths x) in + let targets x = Path.Set.to_sexp (Target.paths x) in Exn.code_error "Build_interpret.targets: cannot have targets \ under a [if_file_exists]" [ "targets-a", targets a @@ -219,7 +220,7 @@ module Rule = struct match targets with | [] -> begin match loc with - | Some loc -> Loc.fail loc "Rule has no targets specified" + | Some loc -> Errors.fail loc "Rule has no targets specified" | None -> Exn.code_error "Build_interpret.Rule.make: no targets" [] end | x :: l -> @@ -230,11 +231,11 @@ module Rule = struct match loc with | None -> Exn.code_error "rule has targets in different directories" - [ "targets", Sexp.To_sexp.list Path.sexp_of_t + [ "targets", Sexp.To_sexp.list Path.to_sexp (List.map targets ~f:Target.path) ] | Some loc -> - Loc.fail loc + Errors.fail loc "Rule has targets in different directories.\nTargets:\n%s" (String.concat ~sep:"\n" (List.map targets ~f:(fun t -> diff --git a/src/build_interpret.mli b/src/build_interpret.mli index 7beace39..6e4989fc 100644 --- a/src/build_interpret.mli +++ b/src/build_interpret.mli @@ -1,3 +1,4 @@ +open! Stdune open! Import module Target : sig diff --git a/src/build_system.ml b/src/build_system.ml index f1e59f63..c2a6a300 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Fiber.O @@ -233,13 +234,13 @@ module Alias0 = struct if not (Path.is_in_build_dir dir) || String.contains name '/' then Exn.code_error "Alias0.make: Invalid alias" [ "name", Sexp.To_sexp.string name - ; "dir", Path.sexp_of_t dir + ; "dir", Path.to_sexp dir ]; { dir; name } let of_user_written_path ~loc path = if not (Path.is_in_build_dir path) then - Loc.fail loc "Invalid alias!\n\ + Errors.fail loc "Invalid alias!\n\ Tried to reference path outside build dir: %S" (Path.to_string_maybe_quoted path); { dir = Path.parent_exn path @@ -304,13 +305,13 @@ module Alias0 = struct match File_tree.find_dir file_tree src_dir with | None -> Build.fail { fail = fun () -> - Loc.fail loc "Don't know about directory %s!" + Errors.fail loc "Don't know about directory %s!" (Path.to_string_maybe_quoted src_dir) } | Some dir -> dep_rec_internal ~name:t.name ~dir ~ctx_dir >>^ fun is_empty -> if is_empty && not (is_standard t.name) then - Loc.fail loc + Errors.fail loc "This alias is empty.\n\ Alias %S is not defined in %s or any of its descendants." t.name (Path.to_string_maybe_quoted src_dir) @@ -461,7 +462,7 @@ let entry_point t ~f = | stack -> Exn.code_error "Build_system.entry_point: called inside the rule generator callback" - ["stack", Sexp.To_sexp.list Path.sexp_of_t stack] + ["stack", Sexp.To_sexp.list Path.to_sexp stack] ); f () @@ -564,7 +565,7 @@ let add_spec t fn spec ~copy_source = | Some (File_spec.T { rule; _ }) -> match copy_source, rule.mode with | true, (Standard | Not_a_rule_stanza) -> - Loc.warn (Internal_rule.loc rule ~dir:(Path.parent_exn fn) + Errors.warn (Internal_rule.loc rule ~dir:(Path.parent_exn fn) ~file_tree:t.file_tree) "File %s is both generated by a rule and present in the source tree.\n\ As a result, the rule is currently ignored, however this will become an error \ @@ -686,7 +687,7 @@ let remove_old_artifacts t ~dir ~subdirs_to_keep = let no_rule_found = let fail fn ~loc = - Loc.fail_opt loc "No rule found for %s" (Utils.describe_target fn) + Errors.fail_opt loc "No rule found for %s" (Utils.describe_target fn) in fun t ~loc fn -> match Utils.analyse_target fn with @@ -1067,7 +1068,7 @@ and load_dir_step2_exn t ~dir ~collector ~lazy_generators = let present_targets = Path.Set.diff source_files_for_targtes absent_targets in - Loc.fail + Errors.fail (rule_loc ~file_tree:t.file_tree ~loc:rule.loc @@ -1275,13 +1276,13 @@ let update_universe t = Utils.Cached_digest.remove universe_file; let n = if Path.exists universe_file then - Sexp.Of_sexp.(parse int) Univ_map.empty - (Io.Sexp.load ~mode:Single universe_file) + 1 + Dsexp.Of_sexp.(parse int) Univ_map.empty + (Dsexp.Io.load ~mode:Single universe_file) + 1 else 0 in make_local_dirs t (Path.Set.singleton Path.build_dir); - Io.write_file universe_file (Sexp.to_string ~syntax:Dune (Sexp.To_sexp.int n)) + Io.write_file universe_file (Dsexp.to_string ~syntax:Dune (Dsexp.To_sexp.int n)) let do_build t ~request = entry_point t ~f:(fun () -> @@ -1535,8 +1536,8 @@ let get_collector t ~dir = "Build_system.get_collector called on external directory" else "Build_system.get_collector called on closed directory") - [ "dir", Path.sexp_of_t dir - ; "load_dir_stack", Sexp.To_sexp.list Path.sexp_of_t t.load_dir_stack + [ "dir", Path.to_sexp dir + ; "load_dir_stack", Sexp.To_sexp.list Path.to_sexp t.load_dir_stack ] let add_rule t (rule : Build_interpret.Rule.t) = @@ -1557,7 +1558,7 @@ let prefix_rules t prefix ~f = | [] -> () | targets -> Exn.code_error "Build_system.prefix_rules' prefix contains targets" - ["targets", Path.Set.sexp_of_t (Build_interpret.Target.paths targets)] + ["targets", Path.Set.to_sexp (Build_interpret.Target.paths targets)] end; let prefix = match t.prefix with @@ -1620,7 +1621,7 @@ module Alias = struct let add_action build_system t ~context ~loc ?(locks=[]) ~stamp action = let def = get_alias_def build_system t in - def.actions <- { stamp = Digest.string (Sexp.to_string ~syntax:Dune stamp) + def.actions <- { stamp = Digest.string (Marshal.to_string stamp []) ; action ; locks ; context diff --git a/src/build_system.mli b/src/build_system.mli index a26e2e77..716dc23b 100644 --- a/src/build_system.mli +++ b/src/build_system.mli @@ -1,5 +1,6 @@ (** Build rules *) +open! Stdune open! Import type t @@ -173,7 +174,7 @@ module Alias : sig -> context:Context.t -> loc:Loc.t option -> ?locks:Path.t list - -> stamp:Sexp.t + -> stamp:_ -> (unit, Action.t) Build.t -> unit end with type build_system := t diff --git a/src/colors.ml b/src/colors.ml index f91eeff8..cee5a400 100644 --- a/src/colors.ml +++ b/src/colors.ml @@ -1,3 +1,4 @@ +open! Stdune open Import type styles = Ansi_color.Style.t list diff --git a/src/colors.mli b/src/colors.mli index 0e6bee3e..1ad9af25 100644 --- a/src/colors.mli +++ b/src/colors.mli @@ -1,4 +1,4 @@ -open Stdune +open! Stdune val colorize : key:string -> string -> string diff --git a/src/compilation_context.ml b/src/compilation_context.ml index 16ba5627..78883c1d 100644 --- a/src/compilation_context.ml +++ b/src/compilation_context.ml @@ -1,3 +1,4 @@ +open! Stdune open Import module SC = Super_context diff --git a/src/compilation_context.mli b/src/compilation_context.mli index 388a812b..529239e8 100644 --- a/src/compilation_context.mli +++ b/src/compilation_context.mli @@ -1,5 +1,6 @@ (** High-level API for compiling OCaml files *) +open! Stdune open Import (** Represent a compilation context. diff --git a/src/config.ml b/src/config.ml index 94bb43a3..057fb962 100644 --- a/src/config.ml +++ b/src/config.ml @@ -1,3 +1,4 @@ +open! Stdune open! Import let local_install_dir = @@ -49,7 +50,7 @@ module Display = struct ; "quiet" , Quiet ] - let t = enum all + let dparse = enum all end module Concurrency = struct @@ -71,7 +72,7 @@ module Concurrency = struct else error - let t = + let dparse = plain_string (fun ~loc s -> match of_string s with | Error m -> of_sexp_errorf loc "%s" m @@ -109,15 +110,15 @@ let default = ; concurrency = if inside_dune then Fixed 1 else Auto } -let t = - let%map display = field "display" Display.t ~default:default.display - and concurrency = field "jobs" Concurrency.t ~default:default.concurrency +let dparse = + let%map display = field "display" Display.dparse ~default:default.display + and concurrency = field "jobs" Concurrency.dparse ~default:default.concurrency in { display ; concurrency } -let t = fields t +let dparse = fields dparse let user_config_file = Path.relative (Path.of_filename_relative_to_initial_cwd Xdg.config_dir) @@ -128,16 +129,16 @@ let () = Lang.register syntax () let load_config_file p = match Which_program.t with - | Dune -> load p ~f:(fun _lang -> t) + | Dune -> load p ~f:(fun _lang -> dparse) | Jbuilder -> Io.with_lexbuf_from_file p ~f:(fun lb -> match Dune_lexer.maybe_first_line lb with | None -> - parse (enter t) + parse (enter dparse) (Univ_map.singleton (Syntax.key syntax) (0, 0)) - (Io.Sexp.load p ~mode:Many_as_one ~lexer:Sexp.Lexer.jbuild_token) + (Dsexp.Io.load p ~mode:Many_as_one ~lexer:Dsexp.Lexer.jbuild_token) | Some first_line -> - parse_contents lb first_line ~f:(fun _lang -> t)) + parse_contents lb first_line ~f:(fun _lang -> dparse)) let load_user_config_file () = if Path.exists user_config_file then diff --git a/src/config.mli b/src/config.mli index 7e03b92e..67392f73 100644 --- a/src/config.mli +++ b/src/config.mli @@ -32,7 +32,7 @@ module Display : sig | Verbose (** Display all commands fully *) | Quiet (** Only display errors *) - val t : t Sexp.Of_sexp.t + val dparse : t Dsexp.Of_sexp.t val all : (string * t) list end @@ -58,7 +58,7 @@ include S with type 'a field = 'a module Partial : S with type 'a field := 'a option -val t : t Sexp.Of_sexp.t +val dparse : t Dsexp.Of_sexp.t val merge : t -> Partial.t -> t diff --git a/src/configurator/dune b/src/configurator/dune index a40b0ea0..418d5cfa 100644 --- a/src/configurator/dune +++ b/src/configurator/dune @@ -3,6 +3,6 @@ (library (name configurator) (public_name dune.configurator) - (libraries stdune ocaml_config) + (libraries stdune ocaml_config dsexp) (flags (:standard -safe-string (:include flags/flags.sexp))) (preprocess no_preprocessing)) diff --git a/src/configurator/v1.ml b/src/configurator/v1.ml index 152022d9..398b49b9 100644 --- a/src/configurator/v1.ml +++ b/src/configurator/v1.ml @@ -1,4 +1,4 @@ -open Stdune +open! Stdune let sprintf = Printf.sprintf let eprintf = Printf.eprintf @@ -75,8 +75,8 @@ module Flags = struct let write_sexp fname s = let path = Path.in_source fname in - let sexp = Usexp.List (List.map s ~f:(fun s -> Usexp.Quoted_string s)) in - Io.write_file path (Usexp.to_string sexp ~syntax:Dune) + let sexp = Dsexp.List (List.map s ~f:(fun s -> Dsexp.Quoted_string s)) in + Io.write_file path (Dsexp.to_string sexp ~syntax:Dune) end module Find_in_path = struct diff --git a/src/context.ml b/src/context.ml index 6d55ae46..2082bcdd 100644 --- a/src/context.ml +++ b/src/context.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Fiber.O @@ -10,8 +11,8 @@ module Kind = struct end type t = Default | Opam of Opam.t - let sexp_of_t : t -> Sexp.t = function - | Default -> Sexp.unsafe_atom_of_string "default" + let to_sexp : t -> Sexp.t = function + | Default -> Sexp.To_sexp.string "default" | Opam o -> Sexp.To_sexp.(record [ "root" , string o.root ; "switch", string o.switch @@ -85,12 +86,12 @@ type t = ; which_cache : (string, Path.t option) Hashtbl.t } -let sexp_of_t t = +let to_sexp t = let open Sexp.To_sexp in - let path = Path.sexp_of_t in + let path = Path.to_sexp in record [ "name", string t.name - ; "kind", Kind.sexp_of_t t.kind + ; "kind", Kind.to_sexp t.kind ; "profile", string t.profile ; "merlin", bool t.merlin ; "for_host", option string (Option.map t.for_host ~f:(fun t -> t.name)) @@ -102,16 +103,16 @@ let sexp_of_t t = ; "ocamlopt", option path t.ocamlopt ; "ocamldep", path t.ocamldep ; "ocamlmklib", path t.ocamlmklib - ; "env", Env.sexp_of_t (Env.diff t.env Env.initial) + ; "env", Env.to_sexp (Env.diff t.env Env.initial) ; "findlib_path", list path (Findlib.path t.findlib) ; "arch_sixtyfour", bool t.arch_sixtyfour ; "natdynlink_supported", bool (Dynlink_supported.By_the_os.get t.natdynlink_supported) ; "supports_shared_libraries", bool (Dynlink_supported.By_the_os.get t.supports_shared_libraries) - ; "opam_vars", string_hashtbl string t.opam_var_cache - ; "ocaml_config", Ocaml_config.sexp_of_t t.ocaml_config - ; "which", string_hashtbl (option path) t.which_cache + ; "opam_vars", Hashtbl.to_sexp string string t.opam_var_cache + ; "ocaml_config", Ocaml_config.to_sexp t.ocaml_config + ; "which", Hashtbl.to_sexp string (option path) t.which_cache ] let compare a b = compare a.name b.name @@ -269,7 +270,7 @@ let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets %s" (Path.to_string ocamlc) msg | Error (Makefile_config file, msg) -> - Loc.fail (Loc.in_file (Path.to_string file)) "%s" msg + Errors.fail (Loc.in_file (Path.to_string file)) "%s" msg in Fiber.fork_and_join findlib_path @@ -451,8 +452,8 @@ let create_for_opam ?root ~env ~env_nodes ~targets ~profile ~switch ~name ["config"; "env"; "--root"; root; "--switch"; switch; "--sexp"] >>= fun s -> let vars = - Usexp.parse_string ~fname:"" ~mode:Single s - |> Sexp.Of_sexp.(parse (list (pair string string)) Univ_map.empty) + Dsexp.parse_string ~fname:"" ~mode:Single s + |> Dsexp.Of_sexp.(parse (list (pair string string)) Univ_map.empty) |> Env.Map.of_list_multi |> Env.Map.mapi ~f:(fun var values -> match List.rev values with diff --git a/src/context.mli b/src/context.mli index 93e0fb28..f81571a5 100644 --- a/src/context.mli +++ b/src/context.mli @@ -18,6 +18,7 @@ it is obtained by looking in another context. *) +open! Stdune open! Import module Kind : sig @@ -127,7 +128,7 @@ type t = ; which_cache : (string, Path.t option) Hashtbl.t } -val sexp_of_t : t -> Sexp.t +val to_sexp : t -> Sexp.t (** Compare the context names *) val compare : t -> t -> Ordering.t diff --git a/src/dep_path.ml b/src/dep_path.ml index 6d014424..8fb0abb7 100644 --- a/src/dep_path.ml +++ b/src/dep_path.ml @@ -1,4 +1,4 @@ -open Import +open! Stdune module Entry = struct type t = @@ -14,8 +14,8 @@ module Entry = struct | Library (path, lib_name) -> sprintf "library %S in %s" lib_name (Path.to_string_maybe_quoted path) | Preprocess l -> - Sexp.to_string ~syntax:Dune - (List [ Sexp.unsafe_atom_of_string "pps" + Sexp.to_string + (List [ Atom "pps" ; Sexp.To_sexp.(list string) l]) | Loc loc -> Loc.to_file_colon_line loc diff --git a/src/dep_path.mli b/src/dep_path.mli index 70cf5fc4..8483946f 100644 --- a/src/dep_path.mli +++ b/src/dep_path.mli @@ -1,6 +1,6 @@ (** Dependency path *) -open Stdune +open! Stdune module Entry : sig type t = diff --git a/src/dir_contents.ml b/src/dir_contents.ml index 4b8d3b78..57a8cc62 100644 --- a/src/dir_contents.ml +++ b/src/dir_contents.ml @@ -1,3 +1,4 @@ +open! Stdune open Import module Menhir_rules = Menhir open Dune_file @@ -39,7 +40,7 @@ end = struct match m with | Ok m -> Some m | Error s -> - Loc.fail loc "Module %a doesn't exist." Module.Name.pp s) + Errors.fail loc "Module %a doesn't exist." Module.Name.pp s) , modules ) @@ -100,28 +101,28 @@ end = struct if missing_intf_only <> [] then begin match Ordered_set_lang.loc buildable.modules_without_implementation with | None -> - Loc.warn buildable.loc + Errors.warn buildable.loc "Some modules don't have an implementation.\ \nYou need to add the following field to this stanza:\ \n\ \n %s\ \n\ \nThis will become an error in the future." - (let tag = Sexp.unsafe_atom_of_string + (let tag = Dsexp.unsafe_atom_of_string "modules_without_implementation" in let modules = missing_intf_only |> uncapitalized - |> List.map ~f:Sexp.To_sexp.string + |> List.map ~f:Dsexp.To_sexp.string in - Sexp.to_string ~syntax:Dune (List (tag :: modules))) + Dsexp.to_string ~syntax:Dune (List (tag :: modules))) | Some loc -> let list_modules l = uncapitalized l |> List.map ~f:(sprintf "- %s") |> String.concat ~sep:"\n" in - Loc.warn loc + Errors.warn loc "The following modules must be listed here as they don't \ have an implementation:\n\ %s\n\ @@ -135,7 +136,7 @@ end = struct |> Option.value_exn in (* CR-soon jdimino for jdimino: report all errors *) - Loc.fail loc + Errors.fail loc "Module %a has an implementation, it cannot be listed here" Module.Name.pp module_name end @@ -154,7 +155,7 @@ end = struct ) in Module.Name.Map.iteri fake_modules ~f:(fun m loc -> - Loc.warn loc "Module %a is excluded but it doesn't exist." + Errors.warn loc "Module %a is excluded but it doesn't exist." Module.Name.pp m ); check_invalid_module_listing ~buildable:conf ~intf_only ~modules @@ -280,8 +281,8 @@ let mlds t (doc : Documentation.t) = | Some x -> x | None -> Exn.code_error "Dir_contents.mlds" - [ "doc", Loc.sexp_of_t doc.loc - ; "available", Sexp.To_sexp.(list Loc.sexp_of_t) + [ "doc", Loc.to_sexp doc.loc + ; "available", Sexp.To_sexp.(list Loc.to_sexp) (List.map map ~f:(fun (d, _) -> d.Documentation.loc)) ] @@ -378,7 +379,7 @@ let build_modules_map (d : Super_context.Dir_with_jbuild.t) ~modules = with | Ok x -> x | Error (name, _, (lib2, _)) -> - Loc.fail lib2.buildable.loc + Errors.fail lib2.buildable.loc "Library %S appears for the second time \ in this directory" name @@ -390,7 +391,7 @@ let build_modules_map (d : Super_context.Dir_with_jbuild.t) ~modules = with | Ok x -> x | Error (name, _, (exes2, _)) -> - Loc.fail exes2.buildable.loc + Errors.fail exes2.buildable.loc "Executable %S appears for the second time \ in this directory" name @@ -416,7 +417,7 @@ let build_modules_map (d : Super_context.Dir_with_jbuild.t) ~modules = Option.some_if (n = name) b.loc) |> List.sort ~compare in - Loc.fail (Loc.in_file (List.hd locs).start.pos_fname) + Errors.fail (Loc.in_file (List.hd locs).start.pos_fname) "Module %a is used in several stanzas:@\n\ @[%a@]@\n\ @[%a@]" @@ -441,7 +442,7 @@ let build_modules_map (d : Super_context.Dir_with_jbuild.t) ~modules = List.sort ~compare (b.Buildable.loc :: List.map rest ~f:(fun b -> b.Buildable.loc)) in - Loc.warn (Loc.in_file b.loc.start.pos_fname) + Errors.warn (Loc.in_file b.loc.start.pos_fname) "Module %a is used in several stanzas:@\n\ @[%a@]@\n\ @[%a@]@\n\ @@ -477,7 +478,7 @@ let build_mlds_map (d : Super_context.Dir_with_jbuild.t) ~files = | Some s -> s | None -> - Loc.fail loc "%s.mld doesn't exist in %s" s + Errors.fail loc "%s.mld doesn't exist in %s" s (Path.to_string_maybe_quoted (Path.drop_optional_build_context dir)) ) @@ -513,7 +514,7 @@ module Dir_status = struct match stanza with | Include_subdirs (loc, x) -> if Option.is_some acc then - Loc.fail loc "The 'include_subdirs' stanza cannot appear \ + Errors.fail loc "The 'include_subdirs' stanza cannot appear \ more than once"; Some x | _ -> acc) @@ -523,7 +524,7 @@ module Dir_status = struct match stanza with | Library { buildable; _} | Executables { buildable; _ } | Tests { exes = { buildable; _ }; _ } -> - Loc.fail buildable.loc + Errors.fail buildable.loc "This stanza is not allowed in a sub-directory of directory with \ (include_subdirs unqualified).\n\ Hint: add (include_subdirs no) to this file." @@ -663,7 +664,7 @@ let rec get sctx ~dir = ~f:(fun acc (dir, files) -> let modules = modules_of_files ~dir ~files in Module.Name.Map.union acc modules ~f:(fun name x y -> - Loc.fail (Loc.in_file + Errors.fail (Loc.in_file (Path.to_string (match File_tree.Dir.dune_file ft_dir with | None -> diff --git a/src/dir_contents.mli b/src/dir_contents.mli index d4480111..08ef8d03 100644 --- a/src/dir_contents.mli +++ b/src/dir_contents.mli @@ -4,6 +4,7 @@ in the source tree or generated by user rules to library, executables, tests and documentation stanzas. *) +open! Stdune open Import type t diff --git a/src/usexp/atom.ml b/src/dsexp/atom.ml similarity index 100% rename from src/usexp/atom.ml rename to src/dsexp/atom.ml diff --git a/src/usexp/atom.mli b/src/dsexp/atom.mli similarity index 100% rename from src/usexp/atom.mli rename to src/dsexp/atom.mli diff --git a/src/dsexp/dsexp.ml b/src/dsexp/dsexp.ml new file mode 100644 index 00000000..cd56265a --- /dev/null +++ b/src/dsexp/dsexp.ml @@ -0,0 +1,869 @@ +open! Stdune + +module Atom = Atom +module Template = Template + +type syntax = Atom.syntax = Jbuild | Dune + +type t = + | Atom of Atom.t + | Quoted_string of string + | List of t list + | Template of Template.t + +let atom_or_quoted_string s = + if Atom.is_valid_dune s then + Atom (Atom.of_string s) + else + Quoted_string s + +let atom s = Atom (Atom.of_string s) + +let unsafe_atom_of_string s = atom s + +let rec to_string t ~syntax = + match t with + | Atom a -> Atom.print a syntax + | Quoted_string s -> Escape.quoted s ~syntax + | List l -> + Printf.sprintf "(%s)" (List.map l ~f:(to_string ~syntax) + |> String.concat ~sep:" ") + | Template t -> Template.to_string t ~syntax + +let rec pp syntax ppf = function + | Atom s -> + Format.pp_print_string ppf (Atom.print s syntax) + | Quoted_string s -> + Format.pp_print_string ppf (Escape.quoted ~syntax s) + | List [] -> + Format.pp_print_string ppf "()" + | List (first :: rest) -> + Format.pp_open_box ppf 1; + Format.pp_print_string ppf "("; + Format.pp_open_hvbox ppf 0; + pp syntax ppf first; + List.iter rest ~f:(fun sexp -> + Format.pp_print_space ppf (); + pp syntax ppf sexp); + Format.pp_close_box ppf (); + Format.pp_print_string ppf ")"; + Format.pp_close_box ppf () + | Template t -> Template.pp syntax ppf t + +let pp_quoted = + let rec loop = function + | Atom (A s) as t -> + if Atom.is_valid_dune s then + t + else + Quoted_string s + | List xs -> List (List.map ~f:loop xs) + | (Quoted_string _ | Template _) as t -> t + in + fun ppf t -> pp Dune ppf (loop t) + +let pp_print_quoted_string ppf s = + let syntax = Dune in + if String.contains s '\n' then begin + match String.split s ~on:'\n' with + | [] -> Format.pp_print_string ppf (Escape.quoted ~syntax s) + | first :: rest -> + Format.fprintf ppf "@[\"@{%s" + (Escape.escaped ~syntax first); + List.iter rest ~f:(fun s -> + Format.fprintf ppf "@,\\n%s" (Escape.escaped ~syntax s)); + Format.fprintf ppf "@}\"@]" + end else + Format.pp_print_string ppf (Escape.quoted ~syntax s) + +let rec pp_split_strings ppf = function + | Atom s -> Format.pp_print_string ppf (Atom.print s Atom.Dune) + | Quoted_string s -> pp_print_quoted_string ppf s + | List [] -> + Format.pp_print_string ppf "()" + | List (first :: rest) -> + Format.pp_open_box ppf 1; + Format.pp_print_string ppf "("; + Format.pp_open_hvbox ppf 0; + pp_split_strings ppf first; + List.iter rest ~f:(fun sexp -> + Format.pp_print_space ppf (); + pp_split_strings ppf sexp); + Format.pp_close_box ppf (); + Format.pp_print_string ppf ")"; + Format.pp_close_box ppf () + | Template t -> Template.pp_split_strings ppf t + +type formatter_state = + | In_atom + | In_makefile_action + | In_makefile_stuff + +let prepare_formatter ppf = + let state = ref [] in + Format.pp_set_mark_tags ppf true; + let ofuncs = Format.pp_get_formatter_out_functions ppf () in + let tfuncs = Format.pp_get_formatter_tag_functions ppf () in + Format.pp_set_formatter_tag_functions ppf + { tfuncs with + mark_open_tag = (function + | "atom" -> state := In_atom :: !state; "" + | "makefile-action" -> state := In_makefile_action :: !state; "" + | "makefile-stuff" -> state := In_makefile_stuff :: !state; "" + | s -> tfuncs.mark_open_tag s) + ; mark_close_tag = (function + | "atom" | "makefile-action" | "makefile-stuff" -> state := List.tl !state; "" + | s -> tfuncs.mark_close_tag s) + }; + Format.pp_set_formatter_out_functions ppf + { ofuncs with + out_newline = (fun () -> + match !state with + | [In_atom; In_makefile_action] -> + ofuncs.out_string "\\\n\t" 0 3 + | [In_atom] -> + ofuncs.out_string "\\\n" 0 2 + | [In_makefile_action] -> + ofuncs.out_string " \\\n\t" 0 4 + | [In_makefile_stuff] -> + ofuncs.out_string " \\\n" 0 3 + | [] -> + ofuncs.out_string "\n" 0 1 + | _ -> assert false) + ; out_spaces = (fun n -> + ofuncs.out_spaces + (match !state with + | In_atom :: _ -> max 0 (n - 2) + | _ -> n)) + } + +module Ast = struct + type dsexp = t + type t = + | Atom of Loc.t * Atom.t + | Quoted_string of Loc.t * string + | Template of Template.t + | List of Loc.t * t list + + let atom_or_quoted_string loc s = + match atom_or_quoted_string s with + | Atom a -> Atom (loc, a) + | Quoted_string s -> Quoted_string (loc, s) + | Template _ + | List _ -> assert false + + let loc (Atom (loc, _) | Quoted_string (loc, _) | List (loc, _) + | Template { loc ; _ }) = loc + + let rec remove_locs t : dsexp = + match t with + | Template t -> Template (Template.remove_locs t) + | Atom (_, s) -> Atom s + | Quoted_string (_, s) -> Quoted_string s + | List (_, l) -> List (List.map l ~f:remove_locs) +end + +let rec add_loc t ~loc : Ast.t = + match t with + | Atom s -> Atom (loc, s) + | Quoted_string s -> Quoted_string (loc, s) + | List l -> List (loc, List.map l ~f:(add_loc ~loc)) + | Template t -> Template { t with loc } + +module Parse_error = struct + include Lexer.Error + + let loc t : Loc.t = { start = t.start; stop = t.stop } + let message t = t.message +end +exception Parse_error = Lexer.Error + +module Lexer = Lexer + +module Parser = struct + let error (loc : Loc.t) message = + raise (Parse_error + { start = loc.start + ; stop = loc.stop + ; message + }) + + module Mode = struct + type 'a t = + | Single : Ast.t t + | Many : Ast.t list t + | Many_as_one : Ast.t t + + let make_result : type a. a t -> Lexing.lexbuf -> Ast.t list -> a + = fun t lexbuf sexps -> + match t with + | Single -> begin + match sexps with + | [sexp] -> sexp + | [] -> error (Loc.of_lexbuf lexbuf) "no s-expression found in input" + | _ :: sexp :: _ -> + error (Ast.loc sexp) "too many s-expressions found in input" + end + | Many -> sexps + | Many_as_one -> + match sexps with + | [] -> List (Loc.in_file lexbuf.lex_curr_p.pos_fname, []) + | x :: l -> + let last = List.fold_left l ~init:x ~f:(fun _ x -> x) in + let loc = { (Ast.loc x) with stop = (Ast.loc last).stop } in + List (loc, x :: l) + end + + let rec loop depth lexer lexbuf acc = + match (lexer lexbuf : Lexer.Token.t) with + | Atom a -> + let loc = Loc.of_lexbuf lexbuf in + loop depth lexer lexbuf (Ast.Atom (loc, a) :: acc) + | Quoted_string s -> + let loc = Loc.of_lexbuf lexbuf in + loop depth lexer lexbuf (Quoted_string (loc, s) :: acc) + | Template t -> + let loc = Loc.of_lexbuf lexbuf in + loop depth lexer lexbuf (Template { t with loc } :: acc) + | Lparen -> + let start = Lexing.lexeme_start_p lexbuf in + let sexps = loop (depth + 1) lexer lexbuf [] in + let stop = Lexing.lexeme_end_p lexbuf in + loop depth lexer lexbuf (List ({ start; stop }, sexps) :: acc) + | Rparen -> + if depth = 0 then + error (Loc.of_lexbuf lexbuf) + "right parenthesis without matching left parenthesis"; + List.rev acc + | Sexp_comment -> + let sexps = + let loc = Loc.of_lexbuf lexbuf in + match loop depth lexer lexbuf [] with + | _ :: sexps -> sexps + | [] -> error loc "s-expression missing after #;" + in + List.rev_append acc sexps + | Eof -> + if depth > 0 then + error (Loc.of_lexbuf lexbuf) + "unclosed parenthesis at end of input"; + List.rev acc + + let parse ~mode ?(lexer=Lexer.token) lexbuf = + loop 0 lexer lexbuf [] + |> Mode.make_result mode lexbuf +end + +let parse_string ~fname ~mode ?lexer str = + let lb = Lexing.from_string str in + lb.lex_curr_p <- + { pos_fname = fname + ; pos_lnum = 1 + ; pos_bol = 0 + ; pos_cnum = 0 + }; + Parser.parse ~mode ?lexer lb + +type dsexp = t + +module To_sexp = struct + type nonrec 'a t = 'a -> t + let unit () = List [] + let string = atom_or_quoted_string + let int n = Atom (Atom.of_int n) + let float f = Atom (Atom.of_float f) + let bool b = Atom (Atom.of_bool b) + let pair fa fb (a, b) = List [fa a; fb b] + let triple fa fb fc (a, b, c) = List [fa a; fb b; fc c] + let list f l = List (List.map l ~f) + let array f a = list f (Array.to_list a) + let option f = function + | None -> List [] + | Some x -> List [f x] + let record l = + List (List.map l ~f:(fun (n, v) -> List [Atom(Atom.of_string n); v])) + + type field = string * dsexp option + + let field name f ?(equal=(=)) ?default v = + match default with + | None -> (name, Some (f v)) + | Some d -> + if equal d v then + (name, None) + else + (name, Some (f v)) + let field_o name f v = (name, Option.map ~f v) + + let record_fields (l : field list) = + List (List.filter_map l ~f:(fun (k, v) -> + Option.map v ~f:(fun v -> List[Atom (Atom.of_string k); v]))) + + let unknown _ = unsafe_atom_of_string "" +end + +module Of_sexp = struct + type ast = Ast.t = + | Atom of Loc.t * Atom.t + | Quoted_string of Loc.t * string + | Template of Template.t + | List of Loc.t * ast list + + type hint = + { on: string + ; candidates: string list + } + + exception Of_sexp of Loc.t * string * hint option + + let of_sexp_error ?hint loc msg = + raise (Of_sexp (loc, msg, hint)) + let of_sexp_errorf ?hint loc fmt = + Printf.ksprintf (fun msg -> of_sexp_error loc ?hint msg) fmt + let no_templates ?hint loc fmt = + Printf.ksprintf (fun msg -> + of_sexp_error loc ?hint ("No variables allowed " ^ msg)) fmt + + type unparsed_field = + { values : Ast.t list + ; entry : Ast.t + ; prev : unparsed_field option (* Previous occurrence of this field *) + } + + module Name = struct + type t = string + let compare a b = + let alen = String.length a and blen = String.length b in + match Int.compare alen blen with + | Eq -> String.compare a b + | ne -> ne + end + + module Name_map = Map.Make(Name) + + type values = Ast.t list + type fields = + { unparsed : unparsed_field Name_map.t + ; known : string list + } + + (* Arguments are: + + - the location of the whole list + - the first atom when parsing a constructor or a field + - the universal map holding the user context + *) + type 'kind context = + | Values : Loc.t * string option * Univ_map.t -> values context + | Fields : Loc.t * string option * Univ_map.t -> fields context + + type ('a, 'kind) parser = 'kind context -> 'kind -> 'a * 'kind + + type 'a t = ('a, values) parser + type 'a fields_parser = ('a, fields) parser + + let return x _ctx state = (x, state) + let (>>=) t f ctx state = + let x, state = t ctx state in + f x ctx state + let (>>|) t f ctx state = + let x, state = t ctx state in + (f x, state) + let (>>>) a b ctx state = + let (), state = a ctx state in + b ctx state + let map t ~f = t >>| f + + let try_ t f ctx state = + try + t ctx state + with exn -> + f exn ctx state + + let get_user_context : type k. k context -> Univ_map.t = function + | Values (_, _, uc) -> uc + | Fields (_, _, uc) -> uc + + let get key ctx state = (Univ_map.find (get_user_context ctx) key, state) + let get_all ctx state = (get_user_context ctx, state) + + let set : type a b k. a Univ_map.Key.t -> a -> (b, k) parser -> (b, k) parser + = fun key v t ctx state -> + match ctx with + | Values (loc, cstr, uc) -> + t (Values (loc, cstr, Univ_map.add uc key v)) state + | Fields (loc, cstr, uc) -> + t (Fields (loc, cstr, Univ_map.add uc key v)) state + + let set_many : type a k. Univ_map.t -> (a, k) parser -> (a, k) parser + = fun map t ctx state -> + match ctx with + | Values (loc, cstr, uc) -> + t (Values (loc, cstr, Univ_map.superpose uc map)) state + | Fields (loc, cstr, uc) -> + t (Fields (loc, cstr, Univ_map.superpose uc map)) state + + let loc : type k. k context -> k -> Loc.t * k = fun ctx state -> + match ctx with + | Values (loc, _, _) -> (loc, state) + | Fields (loc, _, _) -> (loc, state) + + let at_eos : type k. k context -> k -> bool = fun ctx state -> + match ctx with + | Values _ -> state = [] + | Fields _ -> Name_map.is_empty state.unparsed + + let eos ctx state = (at_eos ctx state, state) + + let if_eos ~then_ ~else_ ctx state = + if at_eos ctx state then + then_ ctx state + else + else_ ctx state + + let repeat : 'a t -> 'a list t = + let rec loop t acc ctx l = + match l with + | [] -> (List.rev acc, []) + | _ -> + let x, l = t ctx l in + loop t (x :: acc) ctx l + in + fun t ctx state -> loop t [] ctx state + + let result : type a k. k context -> a * k -> a = + fun ctx (v, state) -> + match ctx with + | Values (_, cstr, _) -> begin + match state with + | [] -> v + | sexp :: _ -> + match cstr with + | None -> + of_sexp_errorf (Ast.loc sexp) "This value is unused" + | Some s -> + of_sexp_errorf (Ast.loc sexp) "Too many argument for %s" s + end + | Fields _ -> begin + match Name_map.choose state.unparsed with + | None -> v + | Some (name, { entry; _ }) -> + let name_loc = + match entry with + | List (_, s :: _) -> Ast.loc s + | _ -> assert false + in + of_sexp_errorf ~hint:{ on = name; candidates = state.known } + name_loc "Unknown field %s" name + end + + let parse t context sexp = + let ctx = Values (Ast.loc sexp, None, context) in + result ctx (t ctx [sexp]) + + let capture ctx state = + let f t = + result ctx (t ctx state) + in + (f, []) + + let end_of_list (Values (loc, cstr, _)) = + match cstr with + | None -> + let loc = { loc with start = loc.stop } in + of_sexp_errorf loc "Premature end of list" + | Some s -> + of_sexp_errorf loc "Not enough arguments for %s" s + [@@inline never] + + let next f ctx sexps = + match sexps with + | [] -> end_of_list ctx + | sexp :: sexps -> (f sexp, sexps) + [@@inline always] + + let next_with_user_context f ctx sexps = + match sexps with + | [] -> end_of_list ctx + | sexp :: sexps -> (f (get_user_context ctx) sexp, sexps) + [@@inline always] + + let peek _ctx sexps = + match sexps with + | [] -> (None, sexps) + | sexp :: _ -> (Some sexp, sexps) + [@@inline always] + + let peek_exn ctx sexps = + match sexps with + | [] -> end_of_list ctx + | sexp :: _ -> (sexp, sexps) + [@@inline always] + + let junk = next ignore + + let junk_everything : type k. (unit, k) parser = fun ctx state -> + match ctx with + | Values _ -> ((), []) + | Fields _ -> ((), { state with unparsed = Name_map.empty }) + + let keyword kwd = + next (function + | Atom (_, s) when Atom.to_string s = kwd -> () + | sexp -> of_sexp_errorf (Ast.loc sexp) "'%s' expected" kwd) + + let match_keyword l ~fallback = + peek >>= function + | Some (Atom (_, A s)) -> begin + match List.assoc l s with + | Some t -> junk >>> t + | None -> fallback + end + | _ -> fallback + + let until_keyword kwd ~before ~after = + let rec loop acc = + peek >>= function + | None -> return (List.rev acc, None) + | Some (Atom (_, A s)) when s = kwd -> + junk >>> after >>= fun x -> + return (List.rev acc, Some x) + | _ -> + before >>= fun x -> + loop (x :: acc) + in + loop [] + + let plain_string f = + next (function + | Atom (loc, A s) | Quoted_string (loc, s) -> f ~loc s + | Template { loc ; _ } | List (loc, _) -> + of_sexp_error loc "Atom or quoted string expected") + + let enter t = + next_with_user_context (fun uc sexp -> + match sexp with + | List (loc, l) -> + let ctx = Values (loc, None, uc) in + result ctx (t ctx l) + | sexp -> + of_sexp_error (Ast.loc sexp) "List expected") + + let if_list ~then_ ~else_ = + peek_exn >>= function + | List _ -> then_ + | _ -> else_ + + let if_paren_colon_form ~then_ ~else_ = + peek_exn >>= function + | List (_, Atom (loc, A s) :: _) when String.is_prefix s ~prefix:":" -> + let name = String.sub s ~pos:1 ~len:(String.length s - 1) in + enter + (junk >>= fun () -> + then_ >>| fun f -> + f (loc, name)) + | _ -> + else_ + + let fix f = + let rec p = lazy (f r) + and r ast = (Lazy.force p) ast in + r + + let loc_between_states : type k. k context -> k -> k -> Loc.t + = fun ctx state1 state2 -> + match ctx with + | Values _ -> begin + match state1 with + | sexp :: rest when rest == state2 -> (* common case *) + Ast.loc sexp + | [] -> + let (Values (loc, _, _)) = ctx in + { loc with start = loc.stop } + | sexp :: rest -> + let loc = Ast.loc sexp in + let rec search last l = + if l == state2 then + { loc with stop = (Ast.loc last).stop } + else + match l with + | [] -> + let (Values (loc, _, _)) = ctx in + { (Ast.loc sexp) with stop = loc.stop } + | sexp :: rest -> + search sexp rest + in + search sexp rest + end + | Fields _ -> + let parsed = + Name_map.merge state1.unparsed state2.unparsed + ~f:(fun _key before after -> + match before, after with + | Some _, None -> before + | _ -> None) + in + match + Name_map.values parsed + |> List.map ~f:(fun f -> Ast.loc f.entry) + |> List.sort ~compare:(fun a b -> + Int.compare a.Loc.start.pos_cnum b.start.pos_cnum) + with + | [] -> + let (Fields (loc, _, _)) = ctx in + loc + | first :: l -> + let last = List.fold_left l ~init:first ~f:(fun _ x -> x) in + { first with stop = last.stop } + + let located t ctx state1 = + let x, state2 = t ctx state1 in + ((loc_between_states ctx state1 state2, x), state2) + + let raw = next (fun x -> x) + + let unit = + next + (function + | List (_, []) -> () + | sexp -> of_sexp_error (Ast.loc sexp) "() expected") + + let basic desc f = + next (function + | Template { loc; _ } | List (loc, _) | Quoted_string (loc, _) -> + of_sexp_errorf loc "%s expected" desc + | Atom (loc, s) -> + match f (Atom.to_string s) with + | Result.Error () -> + of_sexp_errorf loc "%s expected" desc + | Ok x -> x) + + let string = plain_string (fun ~loc:_ x -> x) + let int = + basic "Integer" (fun s -> + match int_of_string s with + | x -> Ok x + | exception _ -> Result.Error ()) + + let float = + basic "Float" (fun s -> + match float_of_string s with + | x -> Ok x + | exception _ -> Result.Error ()) + + let pair a b = + enter + (a >>= fun a -> + b >>= fun b -> + return (a, b)) + + let triple a b c = + enter + (a >>= fun a -> + b >>= fun b -> + c >>= fun c -> + return (a, b, c)) + + let list t = enter (repeat t) + + let array t = list t >>| Array.of_list + + let option t = + enter + (eos >>= function + | true -> return None + | false -> t >>| Option.some) + + let find_cstr cstrs loc name ctx values = + match List.assoc cstrs name with + | Some t -> + result ctx (t ctx values) + | None -> + of_sexp_errorf loc + ~hint:{ on = name + ; candidates = List.map cstrs ~f:fst + } + "Unknown constructor %s" name + + let sum cstrs = + next_with_user_context (fun uc sexp -> + match sexp with + | Atom (loc, A s) -> + find_cstr cstrs loc s (Values (loc, Some s, uc)) [] + | Template { loc; _ } + | Quoted_string (loc, _) -> + of_sexp_error loc "Atom expected" + | List (loc, []) -> + of_sexp_error loc "Non-empty list expected" + | List (loc, name :: args) -> + match name with + | Quoted_string (loc, _) | List (loc, _) | Template { loc; _ } -> + of_sexp_error loc "Atom expected" + | Atom (s_loc, A s) -> + find_cstr cstrs s_loc s (Values (loc, Some s, uc)) args) + + let enum cstrs = + next (function + | Quoted_string (loc, _) + | Template { loc; _ } + | List (loc, _) -> of_sexp_error loc "Atom expected" + | Atom (loc, A s) -> + match List.assoc cstrs s with + | Some value -> value + | None -> + of_sexp_errorf loc + ~hint:{ on = s + ; candidates = List.map cstrs ~f:fst + } + "Unknown value %s" s) + + let bool = enum [ ("true", true); ("false", false) ] + + let consume name state = + { unparsed = Name_map.remove state.unparsed name + ; known = name :: state.known + } + + let add_known name state = + { state with known = name :: state.known } + + let map_validate t ~f ctx state1 = + let x, state2 = t ctx state1 in + match f x with + | Result.Ok x -> (x, state2) + | Error msg -> + let loc = loc_between_states ctx state1 state2 in + of_sexp_errorf loc "%s" msg + + let field_missing loc name = + of_sexp_errorf loc "field %s missing" name + [@@inline never] + + let field_present_too_many_times _ name entries = + match entries with + | _ :: second :: _ -> + of_sexp_errorf (Ast.loc second) "Field %S is present too many times" + name + | _ -> assert false + + let multiple_occurrences ?(on_dup=field_present_too_many_times) uc name last = + let rec collect acc x = + let acc = x.entry :: acc in + match x.prev with + | None -> acc + | Some prev -> collect acc prev + in + on_dup uc name (collect [] last) + [@@inline never] + + let find_single ?on_dup uc state name = + let res = Name_map.find state.unparsed name in + (match res with + | Some ({ prev = Some _; _ } as last) -> + multiple_occurrences uc name last ?on_dup + | _ -> ()); + res + + let field name ?default ?on_dup t (Fields (loc, _, uc)) state = + match find_single uc state name ?on_dup with + | Some { values; entry; _ } -> + let ctx = Values (Ast.loc entry, Some name, uc) in + let x = result ctx (t ctx values) in + (x, consume name state) + | None -> + match default with + | Some v -> (v, add_known name state) + | None -> field_missing loc name + + let field_o name ?on_dup t (Fields (_, _, uc)) state = + match find_single uc state name ?on_dup with + | Some { values; entry; _ } -> + let ctx = Values (Ast.loc entry, Some name, uc) in + let x = result ctx (t ctx values) in + (Some x, consume name state) + | None -> + (None, add_known name state) + + let field_b ?check ?on_dup name = + field name ~default:false ?on_dup + (Option.value check ~default:(return ()) >>= fun () -> + eos >>= function + | true -> return true + | _ -> bool) + + let multi_field name t (Fields (_, _, uc)) state = + let rec loop acc field = + match field with + | None -> acc + | Some { values; prev; entry } -> + let ctx = Values (Ast.loc entry, Some name, uc) in + let x = result ctx (t ctx values) in + loop (x :: acc) prev + in + let res = loop [] (Name_map.find state.unparsed name) in + (res, consume name state) + + let fields t (Values (loc, cstr, uc)) sexps = + let unparsed = + List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp -> + match sexp with + | List (_, name_sexp :: values) -> begin + match name_sexp with + | Atom (_, A name) -> + Name_map.add acc name + { values + ; entry = sexp + ; prev = Name_map.find acc name + } + | List (loc, _) | Quoted_string (loc, _) | Template { loc; _ } -> + of_sexp_error loc "Atom expected" + end + | _ -> + of_sexp_error (Ast.loc sexp) + "S-expression of the form ( ...) expected") + in + let ctx = Fields (loc, cstr, uc) in + let x = result ctx (t ctx { unparsed; known = [] }) in + (x, []) + + let record t = enter (fields t) + + type kind = + | Values of Loc.t * string option + | Fields of Loc.t * string option + + let kind : type k. k context -> k -> kind * k + = fun ctx state -> + match ctx with + | Values (loc, cstr, _) -> (Values (loc, cstr), state) + | Fields (loc, cstr, _) -> (Fields (loc, cstr), state) + + module Let_syntax = struct + let ( $ ) f t = + f >>= fun f -> + t >>| fun t -> + f t + let const = return + end +end + +module type Sexpable = sig + type t + val dparse : t Of_sexp.t + val dgen : t To_sexp.t +end + +let rec to_sexp = function + | Atom (A a) -> Sexp.Atom a + | List s -> List (List.map s ~f:to_sexp) + | Quoted_string s -> Sexp.Atom s + | Template t -> + List + [ Atom "template" + ; Atom (Template.to_string ~syntax:Dune t) + ] + +module Io = struct + let load ?lexer path ~mode = + Io.with_lexbuf_from_file path ~f:(Parser.parse ~mode ?lexer) +end diff --git a/src/dsexp/dsexp.mli b/src/dsexp/dsexp.mli new file mode 100644 index 00000000..65aa565b --- /dev/null +++ b/src/dsexp/dsexp.mli @@ -0,0 +1,410 @@ +open! Stdune +(** Parsing of s-expressions. + + This library is internal to jbuilder and guarantees no API stability.*) + +type syntax = Jbuild | Dune + +module Atom : sig + type t = private A of string [@@unboxed] + + val is_valid : t -> syntax -> bool + + val of_string : string -> t + val to_string : t -> string + + val of_int : int -> t + val of_float : float -> t + val of_bool : bool -> t + val of_int64 : Int64.t -> t + val of_digest : Digest.t -> t +end + +module Template : sig + type var_syntax = Dollar_brace | Dollar_paren | Percent + + type var = + { loc: Loc.t + ; name: string + ; payload: string option + ; syntax: var_syntax + } + + type part = + | Text of string + | Var of var + + type t = + { quoted: bool + ; parts: part list + ; loc: Loc.t + } + + val string_of_var : var -> string + + val to_string : t -> syntax:syntax -> string + + val remove_locs : t -> t +end + +(** The S-expression type *) +type t = + | Atom of Atom.t + | Quoted_string of string + | List of t list + | Template of Template.t + +val atom : string -> t +(** [atom s] convert the string [s] to an Atom. + @raise Invalid_argument if [s] does not satisfy [Atom.is_valid s]. *) + +val atom_or_quoted_string : string -> t + +val unsafe_atom_of_string : string -> t + +(** Serialize a S-expression *) +val to_string : t -> syntax:syntax -> string + +(** Serialize a S-expression using indentation to improve readability *) +val pp : syntax -> Format.formatter -> t -> unit + +(** Serialization that never fails because it quotes atoms when necessary + TODO remove this once we have a proper sexp type *) +val pp_quoted : Format.formatter -> t -> unit + +(** Same as [pp ~syntax:Dune], but split long strings. The formatter + must have been prepared with [prepare_formatter]. *) +val pp_split_strings : Format.formatter -> t -> unit + +(** Prepare a formatter for [pp_split_strings]. Additionaly the + formatter escape newlines when the tags "makefile-action" or + "makefile-stuff" are active. *) +val prepare_formatter : Format.formatter -> unit + +(** Abstract syntax tree *) +module Ast : sig + type sexp = t + type t = + | Atom of Loc.t * Atom.t + | Quoted_string of Loc.t * string + | Template of Template.t + | List of Loc.t * t list + + val atom_or_quoted_string : Loc.t -> string -> t + + val loc : t -> Loc.t + + val remove_locs : t -> sexp +end with type sexp := t + +val add_loc : t -> loc:Loc.t -> Ast.t + +module Parse_error : sig + type t + + val loc : t -> Loc.t + val message : t -> string +end + +(** Exception raised in case of a parsing error *) +exception Parse_error of Parse_error.t + +module Lexer : sig + module Token : sig + type t = + | Atom of Atom.t + | Quoted_string of string + | Lparen + | Rparen + | Sexp_comment + | Eof + | Template of Template.t + end + + type t = Lexing.lexbuf -> Token.t + + val token : t + val jbuild_token : t +end + +module Parser : sig + module Mode : sig + type 'a t = + | Single : Ast.t t + | Many : Ast.t list t + | Many_as_one : Ast.t t + end + + val parse + : mode:'a Mode.t + -> ?lexer:Lexer.t + -> Lexing.lexbuf + -> 'a +end + +val parse_string + : fname:string + -> mode:'a Parser.Mode.t + -> ?lexer:Lexer.t + -> string + -> 'a + +module To_sexp : sig + type sexp = t + include Sexp_intf.Combinators with type 'a t = 'a -> t + + val record : (string * sexp) list -> sexp + + type field + + val field + : string + -> 'a t + -> ?equal:('a -> 'a -> bool) + -> ?default:'a + -> 'a + -> field + val field_o : string -> 'a t-> 'a option -> field + + val record_fields : field list t + + val unknown : _ t +end with type sexp := t + +module Of_sexp : sig + type ast = Ast.t = + | Atom of Loc.t * Atom.t + | Quoted_string of Loc.t * string + | Template of Template.t + | List of Loc.t * ast list + + type hint = + { on: string + ; candidates: string list + } + + exception Of_sexp of Loc.t * string * hint option + + (** Monad producing a value of type ['a] by parsing an input + composed of a sequence of S-expressions. + + The input can be seen either as a plain sequence of + S-expressions or a list of fields. The ['kind] parameter + indicates how the input is seen: + + - with {['kind = [values]]}, the input is seen as an ordered + sequence of S-expressions + + - with {['kind = [fields]]}, the input is seen as an unordered + sequence of fields + + A field is a S-expression of the form: [( ...)] + where [atom] is a plain atom, i.e. not a quoted string and not + containing variables. [values] is a sequence of zero, one or more + S-expressions. + + It is possible to switch between the two mode at any time using + the appropriate combinator. Some primitives can be used in both + mode while some are specific to one mode. *) + type ('a, 'kind) parser + + type values + type fields + + type 'a t = ('a, values) parser + type 'a fields_parser = ('a, fields) parser + + (** [parse parser context sexp] parse a S-expression using the + following parser. The input consist of a single + S-expression. [context] allows to pass extra information such as + versions to individual parsers. *) + val parse : 'a t -> Univ_map.t -> ast -> 'a + + val return : 'a -> ('a, _) parser + val (>>=) : ('a, 'k) parser -> ('a -> ('b, 'k) parser) -> ('b, 'k) parser + val (>>|) : ('a, 'k) parser -> ('a -> 'b) -> ('b, 'k) parser + val (>>>) : (unit, 'k) parser -> ('a, 'k) parser -> ('a, 'k) parser + val map : ('a, 'k) parser -> f:('a -> 'b) -> ('b, 'k) parser + val try_ : ('a, 'k) parser -> (exn -> ('a, 'k) parser) -> ('a, 'k) parser + + (** Access to the context *) + val get : 'a Univ_map.Key.t -> ('a option, _) parser + val set : 'a Univ_map.Key.t -> 'a -> ('b, 'k) parser -> ('b, 'k) parser + val get_all : (Univ_map.t, _) parser + val set_many : Univ_map.t -> ('a, 'k) parser -> ('a, 'k) parser + + (** Return the location of the list currently being parsed. *) + val loc : (Loc.t, _) parser + + (** End of sequence condition. Uses [then_] if there are no more + S-expressions to parse, [else_] otherwise. *) + val if_eos : then_:('a, 'b) parser -> else_:('a, 'b) parser -> ('a, 'b) parser + + (** If the next element of the sequence is a list, parse it with + [then_], otherwise parse it with [else_]. *) + val if_list + : then_:'a t + -> else_:'a t + -> 'a t + + (** If the next element of the sequence is of the form [(: + ...)], use [then_] to parse [...]. Otherwise use [else_]. *) + val if_paren_colon_form + : then_:(Loc.t * string -> 'a) t + -> else_:'a t + -> 'a t + + (** Expect the next element to be the following atom. *) + val keyword : string -> unit t + + (** {[match_keyword [(k1, t1); (k2, t2); ...] ~fallback]} inspects + the next element of the input sequence. If it is an atom equal to + one of [k1], [k2], ... then the corresponding parser is used to + parse the rest of the sequence. Other [fallback] is used. *) + val match_keyword + : (string * 'a t) list + -> fallback:'a t + -> 'a t + + (** Use [before] to parse elements until the keyword is + reached. Then use [after] to parse the rest. *) + val until_keyword + : string + -> before:'a t + -> after:'b t + -> ('a list * 'b option) t + + (** What is currently being parsed. The second argument is the atom + at the beginnig of the list when inside a [sum ...] or [field + ...]. *) + type kind = + | Values of Loc.t * string option + | Fields of Loc.t * string option + val kind : (kind, _) parser + + (** [repeat t] use [t] to consume all remaning elements of the input + until the end of sequence is reached. *) + val repeat : 'a t -> 'a list t + + (** Capture the rest of the input for later parsing *) + val capture : ('a t -> 'a) t + + (** [enter t] expect the next element of the input to be a list and + parse its contents with [t]. *) + val enter : 'a t -> 'a t + + (** [fields fp] converts the rest of the current input to a list of + fields and parse them with [fp]. This operation fails if one the + S-expression in the input is not of the form [( + ...)] *) + val fields : 'a fields_parser -> 'a t + + (** [record fp = enter (fields fp)] *) + val record : 'a fields_parser -> 'a t + + (** Consume the next element of the input as a string, int, char, ... *) + include Sexp_intf.Combinators with type 'a t := 'a t + + (** Unparsed next element of the input *) + val raw : ast t + + (** Inspect the next element of the input without consuming it *) + val peek : ast option t + + (** Same as [peek] but fail if the end of input is reached *) + val peek_exn : ast t + + (** Consume and ignore the next element of the input *) + val junk : unit t + + (** Ignore all the rest of the input *) + val junk_everything : (unit, _) parser + + (** [plain_string f] expects the next element of the input to be a + plain string, i.e. either an atom or a quoted string, but not a + template nor a list. *) + val plain_string : (loc:Loc.t -> string -> 'a) -> 'a t + + val fix : ('a t -> 'a t) -> 'a t + + val of_sexp_error + : ?hint:hint + -> Loc.t + -> string + -> _ + val of_sexp_errorf + : ?hint:hint + -> Loc.t + -> ('a, unit, string, 'b) format4 + -> 'a + + val no_templates + : ?hint:hint + -> Loc.t + -> ('a, unit, string, 'b) format4 + -> 'a + + val located : ('a, 'k) parser -> (Loc.t * 'a, 'k) parser + + val enum : (string * 'a) list -> 'a t + + (** Parser that parse a S-expression of the form [( + ...)] or []. [] is looked up in the list and + the remaining s-expressions are parsed using the corresponding + list parser. *) + val sum : (string * 'a t) list -> 'a t + + (** Check the result of a list parser, and raise a properly located + error in case of failure. *) + val map_validate + : 'a fields_parser + -> f:('a -> ('b, string) Result.t) + -> 'b fields_parser + + (** {3 Parsing record fields} *) + + val field + : string + -> ?default:'a + -> ?on_dup:(Univ_map.t -> string -> Ast.t list -> unit) + -> 'a t + -> 'a fields_parser + val field_o + : string + -> ?on_dup:(Univ_map.t -> string -> Ast.t list -> unit) + -> 'a t + -> 'a option fields_parser + + val field_b + : ?check:(unit t) + -> ?on_dup:(Univ_map.t -> string -> Ast.t list -> unit) + -> string + -> bool fields_parser + + (** A field that can appear multiple times *) + val multi_field + : string + -> 'a t + -> 'a list fields_parser + + (** Default value for [on_dup]. It fails with an appropriate error + message. *) + val field_present_too_many_times : Univ_map.t -> string -> Ast.t list -> _ + + module Let_syntax : sig + val ( $ ) : ('a -> 'b, 'k) parser -> ('a, 'k) parser -> ('b, 'k) parser + val const : 'a -> ('a, _) parser + end +end + +module type Sexpable = sig + type t + val dparse : t Of_sexp.t + val dgen : t To_sexp.t +end + +val to_sexp : t Sexp.To_sexp.t + +module Io : sig + val load : ?lexer:Lexer.t -> Path.t -> mode:'a Parser.Mode.t -> 'a +end diff --git a/src/usexp/dune b/src/dsexp/dune similarity index 59% rename from src/usexp/dune rename to src/dsexp/dune index 763ac837..cea85d7b 100644 --- a/src/usexp/dune +++ b/src/dsexp/dune @@ -1,6 +1,7 @@ (library - (name usexp) + (name dsexp) (synopsis "[Internal] S-expression library") - (public_name dune._usexp)) + (libraries stdune) + (public_name dune._dsexp)) (ocamllex dune_lexer jbuild_lexer) diff --git a/src/usexp/dune_lexer.mli b/src/dsexp/dune_lexer.mli similarity index 100% rename from src/usexp/dune_lexer.mli rename to src/dsexp/dune_lexer.mli diff --git a/src/usexp/dune_lexer.mll b/src/dsexp/dune_lexer.mll similarity index 99% rename from src/usexp/dune_lexer.mll rename to src/dsexp/dune_lexer.mll index 38186bef..16ee66b5 100644 --- a/src/usexp/dune_lexer.mll +++ b/src/dsexp/dune_lexer.mll @@ -1,4 +1,5 @@ { +open! Stdune open Lexer_shared type block_string_line_kind = diff --git a/src/usexp/escape.ml b/src/dsexp/escape.ml similarity index 99% rename from src/usexp/escape.ml rename to src/dsexp/escape.ml index f2753dee..fa652c8e 100644 --- a/src/usexp/escape.ml +++ b/src/dsexp/escape.ml @@ -1,4 +1,4 @@ -open Import +open! Stdune let quote_length s ~syntax = let n = ref 0 in diff --git a/src/usexp/escape.mli b/src/dsexp/escape.mli similarity index 100% rename from src/usexp/escape.mli rename to src/dsexp/escape.mli diff --git a/src/usexp/jbuild_lexer.boot.ml b/src/dsexp/jbuild_lexer.boot.ml similarity index 100% rename from src/usexp/jbuild_lexer.boot.ml rename to src/dsexp/jbuild_lexer.boot.ml diff --git a/src/usexp/jbuild_lexer.mli b/src/dsexp/jbuild_lexer.mli similarity index 100% rename from src/usexp/jbuild_lexer.mli rename to src/dsexp/jbuild_lexer.mli diff --git a/src/usexp/jbuild_lexer.mll b/src/dsexp/jbuild_lexer.mll similarity index 100% rename from src/usexp/jbuild_lexer.mll rename to src/dsexp/jbuild_lexer.mll diff --git a/src/usexp/lexer.ml b/src/dsexp/lexer.ml similarity index 100% rename from src/usexp/lexer.ml rename to src/dsexp/lexer.ml diff --git a/src/usexp/lexer.mli b/src/dsexp/lexer.mli similarity index 100% rename from src/usexp/lexer.mli rename to src/dsexp/lexer.mli diff --git a/src/usexp/lexer_shared.ml b/src/dsexp/lexer_shared.ml similarity index 100% rename from src/usexp/lexer_shared.ml rename to src/dsexp/lexer_shared.ml diff --git a/src/usexp/lexer_shared.mli b/src/dsexp/lexer_shared.mli similarity index 100% rename from src/usexp/lexer_shared.mli rename to src/dsexp/lexer_shared.mli diff --git a/src/usexp/template.ml b/src/dsexp/template.ml similarity index 97% rename from src/usexp/template.ml rename to src/dsexp/template.ml index 01b43d56..9e96f0be 100644 --- a/src/usexp/template.ml +++ b/src/dsexp/template.ml @@ -1,4 +1,4 @@ -open Import +open! Stdune include Types.Template @@ -76,7 +76,7 @@ let pp_split_strings ppf (t : t) = | Var s -> Format.pp_print_string ppf (string_of_var s) | Text s -> - begin match String.split_on_char s ~on:'\n' with + begin match String.split s ~on:'\n' with | [] -> assert false | [s] -> Format.pp_print_string ppf (Escape.escaped ~syntax s) | split -> diff --git a/src/usexp/template.mli b/src/dsexp/template.mli similarity index 97% rename from src/usexp/template.mli rename to src/dsexp/template.mli index 92f44a89..2d0de573 100644 --- a/src/usexp/template.mli +++ b/src/dsexp/template.mli @@ -1,3 +1,5 @@ +open! Stdune + type var_syntax = Types.Template.var_syntax = | Dollar_brace | Dollar_paren diff --git a/src/usexp/types.ml b/src/dsexp/types.ml similarity index 70% rename from src/usexp/types.ml rename to src/dsexp/types.ml index cbfc06d1..5c129ac6 100644 --- a/src/usexp/types.ml +++ b/src/dsexp/types.ml @@ -1,3 +1,5 @@ +open! Stdune + module Template = struct type var_syntax = Dollar_brace | Dollar_paren | Percent @@ -18,11 +20,3 @@ module Template = struct ; loc: Loc.t } end - -module Sexp = struct - type t = - | Atom of Atom.t - | Quoted_string of string - | List of t list - | Template of Template.t -end diff --git a/src/dune b/src/dune index 7e3033b6..8c3e9763 100644 --- a/src/dune +++ b/src/dune @@ -6,7 +6,7 @@ xdg re opam_file_format - usexp + dsexp ocaml_config which_program) (synopsis "Internal Dune library, do not use!") diff --git a/src/dune_env.ml b/src/dune_env.ml index 7f88ac71..ea9178a9 100644 --- a/src/dune_env.ml +++ b/src/dune_env.ml @@ -1,3 +1,4 @@ +open! Stdune type stanza = Stanza.t = .. module Stanza = struct @@ -36,7 +37,7 @@ module Stanza = struct in (pat, configs)) - let t = + let dparse = let%map () = Syntax.since Stanza.syntax (1, 0) and loc = loc and rules = repeat rule diff --git a/src/dune_env.mli b/src/dune_env.mli index afe45c3a..4733165e 100644 --- a/src/dune_env.mli +++ b/src/dune_env.mli @@ -1,4 +1,4 @@ -open Import +open! Stdune type stanza = Stanza.t = .. @@ -18,7 +18,7 @@ module Stanza : sig ; rules : (pattern * config) list } - val t : t Sexp.Of_sexp.t + val dparse : t Dsexp.Of_sexp.t end type stanza += diff --git a/src/dune_file.ml b/src/dune_file.ml index 951d6222..d9f89c76 100644 --- a/src/dune_file.ml +++ b/src/dune_file.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Stanza.Of_sexp @@ -10,7 +11,7 @@ module Jbuild_version = struct type t = | V1 - let t = + let dparse = enum [ "1", V1 ] @@ -53,7 +54,7 @@ module Lib_name : sig val validate : (Loc.t * result) -> wrapped:bool -> t - val t : (Loc.t * result) Sexp.Of_sexp.t + val dparse : (Loc.t * result) Dsexp.Of_sexp.t end = struct type t = string @@ -78,9 +79,9 @@ end = struct let validate (loc, res) ~wrapped = match res, wrapped with | Ok s, _ -> s - | Warn _, true -> Loc.fail loc "%s" wrapped_message - | Warn s, false -> Loc.warn loc "%s" wrapped_message; s - | Invalid, _ -> Loc.fail loc "%s" invalid_message + | Warn _, true -> Errors.fail loc "%s" wrapped_message + | Warn s, false -> Errors.warn loc "%s" wrapped_message; s + | Invalid, _ -> Errors.fail loc "%s" invalid_message let valid_char = function | 'A'..'Z' | 'a'..'z' | '_' | '0'..'9' -> true @@ -110,7 +111,7 @@ end = struct in loop false 0 - let t = plain_string (fun ~loc s -> (loc, of_string s)) + let dparse = plain_string (fun ~loc s -> (loc, of_string s)) end let file = @@ -210,12 +211,12 @@ module Pkg = struct (hint name_s (Package.Name.Map.keys packages |> List.map ~f:Package.Name.to_string))) - let t = + let dparse = let%map p = Dune_project.get_exn () - and (loc, name) = located Package.Name.t in + and (loc, name) = located Package.Name.dparse in match resolve p name with | Ok x -> x - | Error e -> Loc.fail loc "%s" e + | Error e -> Errors.fail loc "%s" e let field stanza = map_validate @@ -266,11 +267,11 @@ module Pps_and_flags = struct in (pps, List.concat flags) - let t = list item >>| split + let dparse = list item >>| split end module Dune_syntax = struct - let t = + let dparse = let%map l, flags = until_keyword "--" ~before:(plain_string (fun ~loc s -> (loc, s))) @@ -286,10 +287,10 @@ module Pps_and_flags = struct (pps, more_flags @ Option.value flags ~default:[]) end - let t = + let dparse = switch_file_kind - ~jbuild:Jbuild_syntax.t - ~dune:Dune_syntax.t + ~jbuild:Jbuild_syntax.dparse + ~dune:Dune_syntax.dparse end module Bindings = struct @@ -301,6 +302,11 @@ module Bindings = struct let fold t ~f ~init = List.fold_left ~f:(fun acc x -> f x acc) ~init t + let map t ~f = + List.map t ~f:(function + | Unnamed a -> Unnamed (f a) + | Named (s, xs) -> Named (s, List.map ~f xs)) + let to_list = List.concat_map ~f:(function | Unnamed x -> [x] @@ -344,17 +350,25 @@ module Bindings = struct in loop String.Set.empty [] l) - let t elem = + let dparse elem = switch_file_kind ~jbuild:(jbuild elem) ~dune:(dune elem) - let sexp_of_t sexp_of_a bindings = + let dgen dgen bindings = + Dsexp.List ( + List.map bindings ~f:(function + | Unnamed a -> dgen a + | Named (name, bindings) -> + Dsexp.List (Dsexp.atom (":" ^ name) :: List.map ~f:dgen bindings)) + ) + + let to_sexp sexp_of_a bindings = Sexp.List ( List.map bindings ~f:(function | Unnamed a -> sexp_of_a a | Named (name, bindings) -> - Sexp.List (Sexp.atom (":" ^ name) :: List.map ~f:sexp_of_a bindings)) + Sexp.List (Sexp.To_sexp.string (":" ^ name) :: List.map ~f:sexp_of_a bindings)) ) end @@ -368,9 +382,18 @@ module Dep_conf = struct | Package of String_with_vars.t | Universe - let t = - let t = - let sw = String_with_vars.t in + let remove_locs = function + | File sw -> File (String_with_vars.remove_locs sw) + | Alias sw -> Alias (String_with_vars.remove_locs sw) + | Alias_rec sw -> Alias_rec (String_with_vars.remove_locs sw) + | Glob_files sw -> Glob_files (String_with_vars.remove_locs sw) + | Source_tree sw -> Source_tree (String_with_vars.remove_locs sw) + | Package sw -> Package (String_with_vars.remove_locs sw) + | Universe -> Universe + + let dparse = + let dparse = + let sw = String_with_vars.dparse in sum [ "file" , (sw >>| fun x -> File x) ; "alias" , (sw >>| fun x -> Alias x) @@ -390,31 +413,33 @@ module Dep_conf = struct ] in if_list - ~then_:t - ~else_:(String_with_vars.t >>| fun x -> File x) + ~then_:dparse + ~else_:(String_with_vars.dparse >>| fun x -> File x) - open Sexp - let sexp_of_t = function + open Dsexp + let dgen = function | File t -> - List [ Sexp.unsafe_atom_of_string "file" - ; String_with_vars.sexp_of_t t ] + List [ Dsexp.unsafe_atom_of_string "file" + ; String_with_vars.dgen t ] | Alias t -> - List [ Sexp.unsafe_atom_of_string "alias" - ; String_with_vars.sexp_of_t t ] + List [ Dsexp.unsafe_atom_of_string "alias" + ; String_with_vars.dgen t ] | Alias_rec t -> - List [ Sexp.unsafe_atom_of_string "alias_rec" - ; String_with_vars.sexp_of_t t ] + List [ Dsexp.unsafe_atom_of_string "alias_rec" + ; String_with_vars.dgen t ] | Glob_files t -> - List [ Sexp.unsafe_atom_of_string "glob_files" - ; String_with_vars.sexp_of_t t ] + List [ Dsexp.unsafe_atom_of_string "glob_files" + ; String_with_vars.dgen t ] | Source_tree t -> - List [ Sexp.unsafe_atom_of_string "files_recursively_in" - ; String_with_vars.sexp_of_t t ] + List [ Dsexp.unsafe_atom_of_string "files_recursively_in" + ; String_with_vars.dgen t ] | Package t -> - List [ Sexp.unsafe_atom_of_string "package" - ; String_with_vars.sexp_of_t t] + List [ Dsexp.unsafe_atom_of_string "package" + ; String_with_vars.dgen t] | Universe -> - Sexp.unsafe_atom_of_string "universe" + Dsexp.unsafe_atom_of_string "universe" + + let to_sexp t = Dsexp.to_sexp (dgen t) end module Preprocess = struct @@ -429,20 +454,20 @@ module Preprocess = struct | Action of Loc.t * Action.Unexpanded.t | Pps of pps - let t = + let dparse = sum [ "no_preprocessing", return No_preprocessing ; "action", - (located Action.Unexpanded.t >>| fun (loc, x) -> + (located Action.Unexpanded.dparse >>| fun (loc, x) -> Action (loc, x)) ; "pps", (let%map loc = loc - and pps, flags = Pps_and_flags.t in + and pps, flags = Pps_and_flags.dparse in Pps { loc; pps; flags; staged = false }) ; "staged_pps", (let%map () = Syntax.since Stanza.syntax (1, 1) and loc = loc - and pps, flags = Pps_and_flags.t in + and pps, flags = Pps_and_flags.dparse in Pps { loc; pps; flags; staged = true }) ] @@ -464,36 +489,36 @@ module Blang = struct ; "<>", Neq ] - let t = + let dparse = let ops = List.map ops ~f:(fun (name, op) -> ( name - , (let%map x = String_with_vars.t - and y = String_with_vars.t + , (let%map x = String_with_vars.dparse + and y = String_with_vars.dparse in Compare (op, x, y)))) in - let t = - fix begin fun (t : String_with_vars.t Blang.t Sexp.Of_sexp.t) -> + let dparse = + fix begin fun (t : String_with_vars.t Blang.t Dsexp.Of_sexp.t) -> if_list ~then_:( [ "or", repeat t >>| (fun x -> Or x) ; "and", repeat t >>| (fun x -> And x) ] @ ops |> sum) - ~else_:(String_with_vars.t >>| fun v -> Expr v) + ~else_:(String_with_vars.dparse >>| fun v -> Expr v) end in let%map () = Syntax.since Stanza.syntax (1, 1) - and t = t + and dparse = dparse in - t + dparse end module Per_module = struct include Per_item.Make(Module.Name) - let t ~default a = + let dparse ~default a = peek_exn >>= function | List (loc, Atom (_, A "per_module") :: _) -> sum [ "per_module", @@ -517,7 +542,7 @@ end module Preprocess_map = struct type t = Preprocess.t Per_module.t - let t = Per_module.t Preprocess.t ~default:Preprocess.No_preprocessing + let dparse = Per_module.dparse Preprocess.dparse ~default:Preprocess.No_preprocessing let no_preprocessing = Per_module.for_all Preprocess.No_preprocessing @@ -537,7 +562,7 @@ end module Lint = struct type t = Preprocess_map.t - let t = Preprocess_map.t + let dparse = Preprocess_map.dparse let default = Preprocess_map.default let no_lint = default @@ -552,7 +577,7 @@ module Js_of_ocaml = struct ; javascript_files : string list } - let t = + let dparse = record (let%map flags = field_oslu "flags" and javascript_files = field "javascript_files" (list string) ~default:[] @@ -617,7 +642,7 @@ module Lib_dep = struct in loop String.Set.empty String.Set.empty preds) - let t = + let dparse = if_list ~then_:( enter @@ -649,9 +674,9 @@ module Lib_deps = struct | Optional | Forbidden - let t = + let dparse = let%map loc = loc - and t = repeat Lib_dep.t + and t = repeat Lib_dep.dparse in let add kind name acc = match String.Map.find acc name with @@ -686,7 +711,7 @@ module Lib_deps = struct : kind String.Map.t); t - let t = parens_removed_in_dune t + let dparse = parens_removed_in_dune dparse let of_pps pps = List.map pps ~f:(fun pp -> Lib_dep.of_pp (Loc.none, pp)) @@ -720,22 +745,22 @@ module Buildable = struct let modules_field name = Ordered_set_lang.field name - let t = + let dparse = let%map loc = loc and preprocess = - field "preprocess" Preprocess_map.t ~default:Preprocess_map.default + field "preprocess" Preprocess_map.dparse ~default:Preprocess_map.default and preprocessor_deps = - field "preprocessor_deps" (list Dep_conf.t) ~default:[] - and lint = field "lint" Lint.t ~default:Lint.default + field "preprocessor_deps" (list Dep_conf.dparse) ~default:[] + and lint = field "lint" Lint.dparse ~default:Lint.default and modules = modules_field "modules" and modules_without_implementation = modules_field "modules_without_implementation" - and libraries = field "libraries" Lib_deps.t ~default:[] + and libraries = field "libraries" Lib_deps.dparse ~default:[] and flags = field_oslu "flags" and ocamlc_flags = field_oslu "ocamlc_flags" and ocamlopt_flags = field_oslu "ocamlopt_flags" and js_of_ocaml = - field "js_of_ocaml" Js_of_ocaml.t ~default:Js_of_ocaml.default + field "js_of_ocaml" Js_of_ocaml.dparse ~default:Js_of_ocaml.default and allow_overlapping_dependencies = field_b "allow_overlapping_dependencies" in @@ -803,7 +828,7 @@ module Sub_system_info = struct val name : Sub_system_name.t val loc : t -> Loc.t val syntax : Syntax.t - val parse : t Sexp.Of_sexp.t + val parse : t Dsexp.Of_sexp.t end let all = Sub_system_name.Table.create ~default_value:None @@ -846,7 +871,7 @@ module Mode_conf = struct end include T - let t = + let dparse = enum [ "byte" , Byte ; "native", Native @@ -861,13 +886,13 @@ module Mode_conf = struct let pp fmt t = Format.pp_print_string fmt (to_string t) - let sexp_of_t t = - Sexp.unsafe_atom_of_string (to_string t) + let dgen t = + Dsexp.unsafe_atom_of_string (to_string t) module Set = struct include Set.Make(T) - let t = list t >>| of_list + let dparse = list dparse >>| of_list let default = of_list [Byte; Best] @@ -886,7 +911,7 @@ module Library = struct | Ppx_deriver | Ppx_rewriter - let t = + let dparse = enum [ "normal" , Normal ; "ppx_deriver" , Ppx_deriver @@ -920,11 +945,11 @@ module Library = struct ; dune_version : Syntax.Version.t } - let t = + let dparse = record - (let%map buildable = Buildable.t + (let%map buildable = Buildable.dparse and loc = loc - and name = field_o "name" Lib_name.t + and name = field_o "name" Lib_name.dparse and public = Public_lib.public_name_field and synopsis = field_o "synopsis" string and install_c_headers = @@ -939,8 +964,8 @@ module Library = struct and c_library_flags = field_oslu "c_library_flags" and virtual_deps = field "virtual_deps" (list (located string)) ~default:[] - and modes = field "modes" Mode_conf.Set.t ~default:Mode_conf.Set.default - and kind = field "kind" Kind.t ~default:Kind.Normal + and modes = field "modes" Mode_conf.Set.dparse ~default:Mode_conf.Set.default + and kind = field "kind" Kind.dparse ~default:Kind.Normal and wrapped = field "wrapped" bool ~default:true and optional = field_b "optional" and self_build_stubs_archive = @@ -1038,7 +1063,7 @@ module Install_conf = struct | List (_, [Atom (_, A src); Atom (_, A "as"); Atom (_, A dst)]) -> junk >>> return { src; dst = Some dst } | sexp -> - of_sexp_error (Sexp.Ast.loc sexp) + of_sexp_error (Dsexp.Ast.loc sexp) "invalid format, or ( as ) expected" type t = @@ -1047,9 +1072,9 @@ module Install_conf = struct ; package : Package.t } - let t = + let dparse = record - (let%map section = field "section" Install.Section.t + (let%map section = field "section" Install.Section.dparse and files = field "files" (list file) and package = Pkg.field "install" in @@ -1105,37 +1130,37 @@ module Executables = struct ] let simple = - Sexp.Of_sexp.enum simple_representations + Dsexp.Of_sexp.enum simple_representations - let t = + let dparse = if_list ~then_: (enter - (let%map mode = Mode_conf.t - and kind = Binary_kind.t in + (let%map mode = Mode_conf.dparse + and kind = Binary_kind.dparse in { mode; kind })) ~else_:simple - let simple_sexp_of_t link_mode = + let simple_dgen link_mode = let is_ok (_, candidate) = compare candidate link_mode = Eq in match List.find ~f:is_ok simple_representations with - | Some (s, _) -> Some (Sexp.unsafe_atom_of_string s) + | Some (s, _) -> Some (Dsexp.unsafe_atom_of_string s) | None -> None - let sexp_of_t link_mode = - match simple_sexp_of_t link_mode with + let dgen link_mode = + match simple_dgen link_mode with | Some s -> s | None -> let { mode; kind } = link_mode in - Sexp.To_sexp.pair Mode_conf.sexp_of_t Binary_kind.sexp_of_t (mode, kind) + Dsexp.To_sexp.pair Mode_conf.dgen Binary_kind.dgen (mode, kind) module Set = struct include Set.Make(T) - let t = - located (list t) >>| fun (loc, l) -> + let dparse = + located (list dparse) >>| fun (loc, l) -> match l with | [] -> of_sexp_errorf loc "No linking mode defined" | l -> @@ -1175,12 +1200,12 @@ module Executables = struct s let common = - let%map buildable = Buildable.t + let%map buildable = Buildable.dparse and (_ : bool) = field "link_executables" ~default:true (Syntax.deleted_in Stanza.syntax (1, 0) >>> bool) - and link_deps = field "link_deps" (list Dep_conf.t) ~default:[] + and link_deps = field "link_deps" (list Dep_conf.dparse) ~default:[] and link_flags = field_oslu "link_flags" - and modes = field "modes" Link_mode.Set.t ~default:Link_mode.Set.default + and modes = field "modes" Link_mode.Set.dparse ~default:Link_mode.Set.default and () = map_validate (field "inline_tests" (repeat junk >>| fun _ -> true) ~default:false) ~f:(function @@ -1240,9 +1265,9 @@ module Executables = struct match Link_mode.Set.best_install_mode t.modes with | None when has_public_name -> let mode_to_string mode = - " - " ^ Sexp.to_string ~syntax:Dune (Link_mode.sexp_of_t mode) in + " - " ^ Dsexp.to_string ~syntax:Dune (Link_mode.dgen mode) in let mode_strings = List.map ~f:mode_to_string Link_mode.installable_modes in - Loc.fail + Errors.fail buildable.loc "No installable mode found for %s.\n\ One of the following modes is required:\n\ @@ -1278,8 +1303,8 @@ module Executables = struct | Some (loc, _) -> let func = match file_kind with - | Jbuild -> Loc.warn - | Dune -> Loc.fail + | Jbuild -> Errors.warn + | Dune -> Errors.fail in func loc "This field is useless without a (public_name%s ...) field." @@ -1358,7 +1383,7 @@ module Rule = struct | Not_a_rule_stanza | Ignore_source_files - let t = + let dparse = enum [ "standard" , Standard ; "fallback" , Fallback @@ -1366,7 +1391,7 @@ module Rule = struct ; "promote-until-clean", Promote_but_delete_on_clean ] - let field = field "mode" t ~default:Standard + let field = field "mode" dparse ~default:Standard end type t = @@ -1411,7 +1436,7 @@ module Rule = struct ] let short_form = - located Action.Unexpanded.t >>| fun (loc, action) -> + located Action.Unexpanded.dparse >>| fun (loc, action) -> { targets = Infer ; deps = Bindings.empty ; action = (loc, action) @@ -1422,10 +1447,11 @@ module Rule = struct let long_form = let%map loc = loc - and action = field "action" (located Action.Unexpanded.t) + and action = field "action" (located Action.Unexpanded.dparse) and targets = field "targets" (list file_in_current_dir) - and deps = field "deps" (Bindings.t Dep_conf.t) ~default:Bindings.empty - and locks = field "locks" (list String_with_vars.t) ~default:[] + and deps = + field "deps" (Bindings.dparse Dep_conf.dparse) ~default:Bindings.empty + and locks = field "locks" (list String_with_vars.dparse) ~default:[] and mode = map_validate (let%map fallback = @@ -1433,7 +1459,7 @@ module Rule = struct ~check:(Syntax.renamed_in Stanza.syntax (1, 0) ~to_:"(mode fallback)") "fallback" - and mode = field_o "mode" Mode.t + and mode = field_o "mode" Mode.dparse in (fallback, mode)) ~f:(function @@ -1472,10 +1498,10 @@ module Rule = struct | Some Action -> short_form end | sexp -> - of_sexp_errorf (Sexp.Ast.loc sexp) + of_sexp_errorf (Dsexp.Ast.loc sexp) "S-expression of the form ( ...) expected" - let t = + let dparse = switch_file_kind ~jbuild:jbuild_syntax ~dune:dune_syntax @@ -1582,7 +1608,7 @@ module Menhir = struct ~desc:"the menhir extension" [ (1, 0) ] - let t = + let dparse = record (let%map merge_into = field_o "merge_into" string and flags = field_oslu "flags" @@ -1599,7 +1625,7 @@ module Menhir = struct let () = Dune_project.Extension.register syntax - (return [ "menhir", t >>| fun x -> [T x] ]) + (return [ "menhir", dparse >>| fun x -> [T x] ]) (* Syntax for jbuild files *) let jbuild_syntax = @@ -1634,15 +1660,15 @@ module Alias_conf = struct else s) - let t = + let dparse = record (let%map name = field "name" alias_name and loc = loc - and package = field_o "package" Pkg.t - and action = field_o "action" (located Action.Unexpanded.t) - and locks = field "locks" (list String_with_vars.t) ~default:[] - and deps = field "deps" (Bindings.t Dep_conf.t) ~default:Bindings.empty - and enabled_if = field_o "enabled_if" Blang.t + and package = field_o "package" Pkg.dparse + and action = field_o "action" (located Action.Unexpanded.dparse) + and locks = field "locks" (list String_with_vars.dparse) ~default:[] + and deps = field "deps" (Bindings.dparse Dep_conf.dparse) ~default:Bindings.empty + and enabled_if = field_o "enabled_if" Blang.dparse in { name ; deps @@ -1665,15 +1691,16 @@ module Tests = struct let gen_parse names = record - (let%map buildable = Buildable.t + (let%map buildable = Buildable.dparse and link_flags = field_oslu "link_flags" and names = names - and package = field_o "package" Pkg.t - and locks = field "locks" (list String_with_vars.t) ~default:[] - and modes = field "modes" Executables.Link_mode.Set.t + and package = field_o "package" Pkg.dparse + and locks = field "locks" (list String_with_vars.dparse) ~default:[] + and modes = field "modes" Executables.Link_mode.Set.dparse ~default:Executables.Link_mode.Set.default - and deps = field "deps" (Bindings.t Dep_conf.t) ~default:Bindings.empty - and enabled_if = field_o "enabled_if" Blang.t + and deps = + field "deps" (Bindings.dparse Dep_conf.dparse) ~default:Bindings.empty + and enabled_if = field_o "enabled_if" Blang.dparse in { exes = { Executables. @@ -1699,7 +1726,7 @@ module Copy_files = struct ; glob : String_with_vars.t } - let t = String_with_vars.t + let dparse = String_with_vars.dparse end module Documentation = struct @@ -1709,7 +1736,7 @@ module Documentation = struct ; mld_files : Ordered_set_lang.t } - let t = + let dparse = record (let%map package = Pkg.field "documentation" and mld_files = Ordered_set_lang.field "mld_files" @@ -1724,7 +1751,7 @@ end module Include_subdirs = struct type t = No | Unqualified - let t = + let dparse = enum [ "no", No ; "unqualified", Unqualified @@ -1756,17 +1783,17 @@ module Stanzas = struct type Stanza.t += Include of Loc.t * string - type constructors = (string * Stanza.t list Sexp.Of_sexp.t) list + type constructors = (string * Stanza.t list Dsexp.Of_sexp.t) list let stanzas : constructors = [ "library", - (let%map x = Library.t in + (let%map x = Library.dparse in [Library x]) ; "executable" , Executables.single >>| execs ; "executables", Executables.multi >>| execs ; "rule", (let%map loc = loc - and x = Rule.t in + and x = Rule.dparse in [Rule { x with loc }]) ; "ocamllex", (let%map loc = loc @@ -1777,27 +1804,27 @@ module Stanzas = struct and x = Rule.ocamlyacc in rules (Rule.ocamlyacc_to_rule loc x)) ; "install", - (let%map x = Install_conf.t in + (let%map x = Install_conf.dparse in [Install x]) ; "alias", - (let%map x = Alias_conf.t in + (let%map x = Alias_conf.dparse in [Alias x]) ; "copy_files", - (let%map glob = Copy_files.t in + (let%map glob = Copy_files.dparse in [Copy_files {add_line_directive = false; glob}]) ; "copy_files#", - (let%map glob = Copy_files.t in + (let%map glob = Copy_files.dparse in [Copy_files {add_line_directive = true; glob}]) ; "include", (let%map loc = loc and fn = relative_file in [Include (loc, fn)]) ; "documentation", - (let%map d = Documentation.t in + (let%map d = Documentation.dparse in [Documentation d]) ; "jbuild_version", (let%map () = Syntax.deleted_in Stanza.syntax (1, 0) - and _ = Jbuild_version.t in + and _ = Jbuild_version.dparse in []) ; "tests", (let%map () = Syntax.since Stanza.syntax (1, 0) @@ -1808,11 +1835,11 @@ module Stanzas = struct and t = Tests.single in [Tests t]) ; "env", - (let%map x = Dune_env.Stanza.t in + (let%map x = Dune_env.Stanza.dparse in [Dune_env.T x]) ; "include_subdirs", (let%map () = Syntax.since Stanza.syntax (1, 1) - and t = Include_subdirs.t + and t = Include_subdirs.dparse and loc = loc in [Include_subdirs (loc, t)]) ] @@ -1837,18 +1864,18 @@ module Stanzas = struct exception Include_loop of Path.t * (Loc.t * Path.t) list let rec parse stanza_parser ~lexer ~current_file ~include_stack sexps = - List.concat_map sexps ~f:(Sexp.Of_sexp.parse stanza_parser Univ_map.empty) + List.concat_map sexps ~f:(Dsexp.Of_sexp.parse stanza_parser Univ_map.empty) |> List.concat_map ~f:(function | Include (loc, fn) -> let include_stack = (loc, current_file) :: include_stack in let dir = Path.parent_exn current_file in let current_file = Path.relative dir fn in if not (Path.exists current_file) then - Loc.fail loc "File %s doesn't exist." + Errors.fail loc "File %s doesn't exist." (Path.to_string_maybe_quoted current_file); if List.exists include_stack ~f:(fun (_, f) -> Path.equal f current_file) then raise (Include_loop (current_file, include_stack)); - let sexps = Io.Sexp.load ~lexer current_file ~mode:Many in + let sexps = Dsexp.Io.load ~lexer current_file ~mode:Many in parse stanza_parser sexps ~lexer ~current_file ~include_stack | stanza -> [stanza]) @@ -1856,8 +1883,8 @@ module Stanzas = struct let (stanza_parser, lexer) = let (parser, lexer) = match (kind : File_tree.Dune_file.Kind.t) with - | Jbuild -> (jbuild_parser, Usexp.Lexer.jbuild_token) - | Dune -> (Dune_project.stanza_parser project, Usexp.Lexer.token) + | Jbuild -> (jbuild_parser, Dsexp.Lexer.jbuild_token) + | Dune -> (Dune_project.stanza_parser project, Dsexp.Lexer.token) in (Dune_project.set project parser, lexer) in @@ -1873,7 +1900,7 @@ module Stanzas = struct (Path.to_string_maybe_quoted file) loc.Loc.start.pos_lnum in - Loc.fail loc + Errors.fail loc "Recursive inclusion of jbuild files detected:\n\ File %s is included from %s%s" (Path.to_string_maybe_quoted file) @@ -1889,6 +1916,6 @@ module Stanzas = struct ~f:(function Dune_env.T e -> Some e | _ -> None) with | _ :: e :: _ -> - Loc.fail e.loc "The 'env' stanza cannot appear more than once" + Errors.fail e.loc "The 'env' stanza cannot appear more than once" | _ -> stanzas end diff --git a/src/dune_file.mli b/src/dune_file.mli index 742f1d2c..e14ebc52 100644 --- a/src/dune_file.mli +++ b/src/dune_file.mli @@ -1,5 +1,6 @@ (** Representation and parsing of jbuild files *) +open! Stdune open Import (** Ppx preprocessors *) @@ -90,6 +91,8 @@ module Bindings : sig type 'a t = 'a one list + val map : 'a t -> f:('a -> 'b) -> 'b t + val find : 'a t -> string -> 'a list option val fold : 'a t -> f:('a one -> 'acc -> 'acc) -> init:'acc -> 'acc @@ -100,7 +103,9 @@ module Bindings : sig val singleton : 'a -> 'a t - val sexp_of_t : ('a -> Usexp.t) -> 'a t -> Usexp.t + val dgen : 'a Dsexp.To_sexp.t -> 'a t Dsexp.To_sexp.t + + val to_sexp : 'a Sexp.To_sexp.t -> 'a t Sexp.To_sexp.t end module Dep_conf : sig @@ -113,8 +118,10 @@ module Dep_conf : sig | Package of String_with_vars.t | Universe - val t : t Sexp.Of_sexp.t - val sexp_of_t : t -> Sexp.t + val remove_locs : t -> t + + include Dsexp.Sexpable with type t := t + val to_sexp : t Sexp.To_sexp.t end module Buildable : sig @@ -170,7 +177,7 @@ module Sub_system_info : sig val syntax : Syntax.t (** Parse parameters written by the user in jbuid/dune files *) - val parse : t Sexp.Of_sexp.t + val parse : t Dsexp.Of_sexp.t end module Register(M : S) : sig end @@ -184,13 +191,13 @@ module Mode_conf : sig | Native | Best (** [Native] if available and [Byte] if not *) - val t : t Sexp.Of_sexp.t + val dparse : t Dsexp.Of_sexp.t val compare : t -> t -> Ordering.t val pp : Format.formatter -> t -> unit module Set : sig include Set.S with type elt = t - val t : t Sexp.Of_sexp.t + val dparse : t Dsexp.Of_sexp.t (** Both Byte and Native *) val default : t @@ -260,8 +267,7 @@ module Executables : sig ; kind : Binary_kind.t } - val t : t Sexp.Of_sexp.t - val sexp_of_t : t Sexp.To_sexp.t + include Dsexp.Sexpable with type t := t val exe : t val object_ : t @@ -391,6 +397,6 @@ module Stanzas : sig : file:Path.t -> kind:File_tree.Dune_file.Kind.t -> Dune_project.t - -> Sexp.Ast.t list + -> Dsexp.Ast.t list -> t end diff --git a/src/dune_fmt.ml b/src/dune_fmt.ml index 7630c2c7..950456f8 100644 --- a/src/dune_fmt.ml +++ b/src/dune_fmt.ml @@ -1,3 +1,4 @@ +open! Stdune open! Import let parse_file path_opt = @@ -13,20 +14,20 @@ let parse_file path_opt = let contents = String.concat ~sep:"\n" lines in ("", contents) in - Sexp.parse_string + Dsexp.parse_string ~fname - ~mode:Usexp.Parser.Mode.Many + ~mode:Dsexp.Parser.Mode.Many contents let can_be_displayed_inline = List.for_all ~f:(function - | Usexp.Atom _ - | Usexp.Quoted_string _ - | Usexp.Template _ - | Usexp.List [_] + | Dsexp.Atom _ + | Dsexp.Quoted_string _ + | Dsexp.Template _ + | Dsexp.List [_] -> true - | Usexp.List _ + | Dsexp.List _ -> false ) @@ -42,21 +43,21 @@ let print_inline_list fmt indent sexps = first := false else Format.pp_print_string fmt " "; - Usexp.pp Usexp.Dune fmt sexp + Dsexp.pp Dsexp.Dune fmt sexp ); Format.pp_print_string fmt ")" let rec pp_sexp indent fmt = function - ( Usexp.Atom _ - | Usexp.Quoted_string _ - | Usexp.Template _ + ( Dsexp.Atom _ + | Dsexp.Quoted_string _ + | Dsexp.Template _ ) as sexp -> Format.fprintf fmt "%a%a" pp_indent indent - (Usexp.pp Usexp.Dune) sexp - | Usexp.List sexps + (Dsexp.pp Dsexp.Dune) sexp + | Dsexp.List sexps -> if can_be_displayed_inline sexps then print_inline_list fmt indent sexps @@ -96,7 +97,7 @@ let pp_top_sexps fmt sexps = first := false else Format.pp_print_string fmt "\n"; - pp_top_sexp fmt (Sexp.Ast.remove_locs sexp); + pp_top_sexp fmt (Dsexp.Ast.remove_locs sexp); ) let with_output path_opt k = @@ -110,10 +111,10 @@ let with_output path_opt k = let format_file ~input ~output = match parse_file input with - | exception Usexp.Parse_error e -> + | exception Dsexp.Parse_error e -> Printf.printf "Parse error: %s\n" - (Usexp.Parse_error.message e) + (Dsexp.Parse_error.message e) | sexps -> with_output output (fun fmt -> pp_top_sexps fmt sexps; diff --git a/src/dune_lexer.mli b/src/dune_lexer.mli index 2067c6c7..fcd58357 100644 --- a/src/dune_lexer.mli +++ b/src/dune_lexer.mli @@ -1,3 +1,5 @@ +open! Stdune + (** Returns [true] if the input starts with "(* -*- tuareg -*- *)" *) val is_script : Lexing.lexbuf -> bool diff --git a/src/dune_lexer.mll b/src/dune_lexer.mll index 603c9407..8ef02dff 100644 --- a/src/dune_lexer.mll +++ b/src/dune_lexer.mll @@ -1,4 +1,5 @@ { +open! Stdune type first_line = { lang : Loc.t * string ; version : Loc.t * string @@ -11,7 +12,7 @@ let make_loc lexbuf : Loc.t = let invalid_lang_line start lexbuf = lexbuf.Lexing.lex_start_p <- start; - Loc.fail_lex lexbuf + Errors.fail_lex lexbuf "Invalid first line, expected: (lang )" } diff --git a/src/dune_project.ml b/src/dune_project.ml index a5ac25d8..f7c20feb 100644 --- a/src/dune_project.ml +++ b/src/dune_project.ml @@ -1,13 +1,14 @@ +open! Stdune open Import -open Sexp.Of_sexp +open Dsexp.Of_sexp module Kind = struct type t = | Dune | Jbuilder - let sexp_of_t t = - Sexp.atom_or_quoted_string + let to_sexp t = + Sexp.Atom (match t with | Dune -> "dune" | Jbuilder -> "jbuilder") @@ -22,8 +23,8 @@ module Name : sig val to_string_hum : t -> string - val named_of_sexp : t Sexp.Of_sexp.t - val sexp_of_t : t Sexp.To_sexp.t + val dparse : t Dsexp.Of_sexp.t + val to_sexp : t Sexp.To_sexp.t val encode : t -> string val decode : string -> t @@ -58,11 +59,11 @@ end = struct | Named s -> s | Anonymous p -> sprintf "" (Path.to_string_maybe_quoted p) - let sexp_of_t = function + let to_sexp = function | Named s -> Sexp.To_sexp.string s | Anonymous p -> - List [ Sexp.unsafe_atom_of_string "anonymous" - ; Path.sexp_of_t p + List [ Atom "anonymous" + ; Path.to_sexp p ] let validate name = @@ -84,12 +85,12 @@ end = struct else None - let named_of_sexp = - Sexp.Of_sexp.plain_string (fun ~loc s -> + let dparse = + Dsexp.Of_sexp.plain_string (fun ~loc s -> if validate s then Named s else - Sexp.Of_sexp.of_sexp_errorf loc "invalid project name") + Dsexp.Of_sexp.of_sexp_errorf loc "invalid project name") let encode = function | Named s -> s @@ -131,10 +132,10 @@ module Project_file = struct ; mutable exists : bool } - let sexp_of_t { file; exists } = + let to_sexp { file; exists } = Sexp.To_sexp.( record - [ "file", Path.sexp_of_t file + [ "file", Path.to_sexp file ; "exists", bool exists ]) end @@ -145,7 +146,7 @@ type t = ; root : Path.Local.t ; version : string option ; packages : Package.t Package.Name.Map.t - ; stanza_parser : Stanza.t list Sexp.Of_sexp.t + ; stanza_parser : Stanza.t list Dsexp.Of_sexp.t ; project_file : Project_file.t } @@ -202,14 +203,14 @@ let append_to_project_file t str = module Extension = struct type t = { syntax : Syntax.t - ; stanzas : Stanza.Parser.t list Sexp.Of_sexp.t + ; stanzas : Stanza.Parser.t list Dsexp.Of_sexp.t } type instance = { extension : t ; version : Syntax.Version.t ; loc : Loc.t - ; parse_args : Stanza.Parser.t list Sexp.Of_sexp.t -> Stanza.Parser.t list + ; parse_args : Stanza.Parser.t list Dsexp.Of_sexp.t -> Stanza.Parser.t list } let extensions = Hashtbl.create 32 @@ -224,7 +225,7 @@ module Extension = struct let instantiate ~loc ~parse_args (name_loc, name) (ver_loc, ver) = match Hashtbl.find extensions name with | None -> - Loc.fail name_loc "Unknown extension %S.%s" name + Errors.fail name_loc "Unknown extension %S.%s" name (hint name (Hashtbl.keys extensions)) | Some t -> Syntax.check_supported t.syntax (ver_loc, ver); @@ -242,7 +243,7 @@ module Extension = struct if f name then let version = Syntax.greatest_supported_version ext.syntax in let parse_args p = - let open Sexp.Of_sexp in + let open Dsexp.Of_sexp in let dune_project_edited = ref false in parse (enter p) Univ_map.empty (List (Loc.of_pos __POS__, [])) |> List.map ~f:(fun (name, p) -> @@ -251,10 +252,10 @@ module Extension = struct if not !dune_project_edited then begin dune_project_edited := true; Project_file_edit.append project_file - (Sexp.to_string ~syntax:Dune - (List [ Sexp.atom "using" - ; Sexp.atom name - ; Sexp.atom (Syntax.Version.to_string version) + (Dsexp.to_string ~syntax:Dune + (List [ Dsexp.atom "using" + ; Dsexp.atom name + ; Dsexp.atom (Syntax.Version.to_string version) ])) end; p)) @@ -279,16 +280,16 @@ let key = (fun { name; root; version; project_file; kind ; stanza_parser = _; packages = _ } -> Sexp.To_sexp.record - [ "name", Name.sexp_of_t name - ; "root", Path.Local.sexp_of_t root + [ "name", Name.to_sexp name + ; "root", Path.Local.to_sexp root ; "version", Sexp.To_sexp.(option string) version - ; "project_file", Project_file.sexp_of_t project_file - ; "kind", Kind.sexp_of_t kind + ; "project_file", Project_file.to_sexp project_file + ; "kind", Kind.to_sexp kind ]) -let set t = Sexp.Of_sexp.set key t +let set t = Dsexp.Of_sexp.set key t let get_exn () = - let open Sexp.Of_sexp in + let open Dsexp.Of_sexp in get key >>| function | Some t -> t | None -> @@ -310,7 +311,7 @@ let anonymous = lazy ( ; root = get_local_path Path.root ; version = None ; stanza_parser = - Sexp.Of_sexp.(set_many parsing_context (sum lang.data)) + Dsexp.Of_sexp.(set_many parsing_context (sum lang.data)) ; project_file = { file = Path.relative Path.root filename; exists = false } }) @@ -330,12 +331,12 @@ let default_name ~dir ~packages = match Name.named name with | Some x -> x | None -> - Loc.fail (Loc.in_file (Path.to_string (Package.opam_file pkg))) + Errors.fail (Loc.in_file (Path.to_string (Package.opam_file pkg))) "%S is not a valid opam package name." name let name_field ~dir ~packages = - let%map name = field_o "name" Name.named_of_sexp in + let%map name = field_o "name" Name.dparse in match name with | Some x -> x | None -> default_name ~dir ~packages @@ -348,7 +349,7 @@ let parse ~dir ~lang ~packages ~file = multi_field "using" (let%map loc = loc and name = located string - and ver = located Syntax.Version.t + and ver = located Syntax.Version.dparse and parse_args = capture in (* We don't parse the arguments quite yet as we want to set @@ -361,7 +362,7 @@ let parse ~dir ~lang ~packages ~file = (Syntax.name e.extension.syntax, e.loc))) with | Error (name, _, loc) -> - Loc.fail loc "Extension %S specified for the second time." name + Errors.fail loc "Extension %S specified for the second time." name | Ok map -> let project_file : Project_file.t = { file; exists = true } in let extensions = @@ -375,14 +376,14 @@ let parse ~dir ~lang ~packages ~file = (lang.data :: List.map extensions ~f:(fun (ext : Extension.instance) -> ext.parse_args - (Sexp.Of_sexp.set_many parsing_context ext.extension.stanzas))) + (Dsexp.Of_sexp.set_many parsing_context ext.extension.stanzas))) in { kind = Dune ; name ; root = get_local_path dir ; version ; packages - ; stanza_parser = Sexp.Of_sexp.(set_many parsing_context (sum stanzas)) + ; stanza_parser = Dsexp.Of_sexp.(set_many parsing_context (sum stanzas)) ; project_file }) @@ -399,7 +400,7 @@ let make_jbuilder_project ~dir packages = ; version = None ; packages ; stanza_parser = - Sexp.Of_sexp.(set_many parsing_context (sum lang.data)) + Dsexp.Of_sexp.(set_many parsing_context (sum lang.data)) ; project_file = { file = Path.relative dir filename; exists = false } } diff --git a/src/dune_project.mli b/src/dune_project.mli index 2b073f2f..e8ed44f2 100644 --- a/src/dune_project.mli +++ b/src/dune_project.mli @@ -1,3 +1,4 @@ +open! Stdune (** dune-project files *) open Import @@ -22,7 +23,7 @@ module Name : sig (** Convert to a string that is suitable for human readable messages *) val to_string_hum : t -> string - val sexp_of_t : t -> Sexp.t + val to_sexp : t Sexp.To_sexp.t (** Convert to/from an encoded string that is suitable to use in filenames *) val encode : t -> string @@ -41,7 +42,7 @@ val packages : t -> Package.t Package.Name.Map.t val version : t -> string option val name : t -> Name.t val root : t -> Path.Local.t -val stanza_parser : t -> Stanza.t list Sexp.Of_sexp.t +val stanza_parser : t -> Stanza.t list Dsexp.Of_sexp.t module Lang : sig (** [register id stanzas_parser] register a new language. Users will @@ -62,7 +63,7 @@ module Extension : sig in their [dune-project] file. [parser] is used to describe what [] might be. *) - val register : Syntax.t -> Stanza.Parser.t list Sexp.Of_sexp.t -> unit + val register : Syntax.t -> Stanza.Parser.t list Dsexp.Of_sexp.t -> unit end (** Load a project description from the following directory. [files] @@ -86,5 +87,5 @@ val ensure_project_file_exists : t -> unit val append_to_project_file : t -> string -> unit (** Set the project we are currently parsing dune files for *) -val set : t -> ('a, 'k) Sexp.Of_sexp.parser -> ('a, 'k) Sexp.Of_sexp.parser -val get_exn : unit -> (t, 'k) Sexp.Of_sexp.parser +val set : t -> ('a, 'k) Dsexp.Of_sexp.parser -> ('a, 'k) Dsexp.Of_sexp.parser +val get_exn : unit -> (t, 'k) Dsexp.Of_sexp.parser diff --git a/src/env.ml b/src/env.ml index 4eb5df57..7d2a5fc9 100644 --- a/src/env.ml +++ b/src/env.ml @@ -1,3 +1,4 @@ +open! Stdune open Import module Var = struct @@ -62,7 +63,7 @@ let extend t ~vars = let extend_env x y = extend x ~vars:y.vars -let sexp_of_t t = +let to_sexp t = let open Sexp.To_sexp in (list (pair string string)) (Map.to_list t.vars) diff --git a/src/env.mli b/src/env.mli index 8b20f1ae..c7a15429 100644 --- a/src/env.mli +++ b/src/env.mli @@ -1,4 +1,4 @@ -open Import +open! Stdune module Var : sig type t = string @@ -28,6 +28,6 @@ val diff : t -> t -> t val update : t -> var:string -> f:(string option -> string option) -> t -val sexp_of_t : t -> Sexp.t +val to_sexp : t -> Sexp.t val of_string_map : string String.Map.t -> t diff --git a/src/errors.ml b/src/errors.ml index e0f0c527..302d0a73 100644 --- a/src/errors.ml +++ b/src/errors.ml @@ -1,4 +1,4 @@ -open Stdune +open! Stdune exception Already_reported @@ -15,3 +15,84 @@ let kerrf fmt ~f = let die fmt = kerrf fmt ~f:(fun s -> raise (Exn.Fatal_error s)) + +let exnf t fmt = + Format.pp_open_box err_ppf 0; + Format.pp_print_as err_ppf 7 ""; (* "Error: " *) + kerrf (fmt^^ "@]") ~f:(fun s -> Exn.Loc_error (t, s)) + +let fail t fmt = + Format.pp_print_as err_ppf 7 ""; (* "Error: " *) + kerrf fmt ~f:(fun s -> + raise (Exn.Loc_error (t, s))) + +let fail_lex lb fmt = + fail (Loc.of_lexbuf lb) fmt + +let fail_opt t fmt = + match t with + | None -> die fmt + | Some t -> fail t fmt + +let file_line path n = + Io.with_file_in ~binary:false path + ~f:(fun ic -> + for _ = 1 to n - 1 do + ignore (input_line ic) + done; + input_line ic + ) + +let file_lines path ~start ~stop = + Io.with_file_in ~binary:true path + ~f:(fun ic -> + let rec aux acc lnum = + if lnum > stop then + List.rev acc + else if lnum < start then + (ignore (input_line ic); + aux acc (lnum + 1)) + else + let line = input_line ic in + aux ((string_of_int lnum, line) :: acc) (lnum + 1) + in + aux [] 1 + ) + +let print ppf loc = + let { Loc.start; stop } = loc in + let start_c = start.pos_cnum - start.pos_bol in + let stop_c = stop.pos_cnum - start.pos_bol in + let num_lines = stop.pos_lnum - start.pos_lnum in + let pp_file_excerpt pp () = + let whole_file = start_c = 0 && stop_c = 0 in + if not whole_file then + let path = Path.of_string start.pos_fname in + if Path.exists path then + let line = file_line path start.pos_lnum in + if stop_c <= String.length line then + let len = stop_c - start_c in + Format.fprintf pp "%s\n%*s\n" line + stop_c + (String.make len '^') + else if num_lines <= 10 then + let lines = file_lines path ~start:start.pos_lnum ~stop:stop.pos_lnum in + let last_lnum = Option.map ~f:fst (List.last lines) in + let padding_width = Option.value_exn + (Option.map ~f:String.length last_lnum) in + List.iter ~f:(fun (lnum, l) -> + Format.fprintf pp "%*s: %s\n" padding_width lnum l) + lines + in + Format.fprintf ppf + "@{File \"%s\", line %d, characters %d-%d:@}@\n%a" + start.pos_fname start.pos_lnum start_c stop_c + pp_file_excerpt () + +(* This is ugly *) +let printer = ref (Printf.eprintf "%s%!") +let print_to_console s = !printer s + +let warn t fmt = + kerrf ~f:print_to_console + ("%a@{Warning@}: " ^^ fmt ^^ "@.") print t diff --git a/src/errors.mli b/src/errors.mli index 2860b5e9..acad7641 100644 --- a/src/errors.mli +++ b/src/errors.mli @@ -1,3 +1,4 @@ +open Stdune (** Dealing with errors *) (* CR-soon diml: stop including this in [Import] *) @@ -21,3 +22,18 @@ val kerrf : ('a, Format.formatter, unit, 'b) format4 -> f:(string -> 'b) -> 'a + +val exnf : Loc.t -> ('a, Format.formatter, unit, exn) format4 -> 'a +val fail : Loc.t -> ('a, Format.formatter, unit, 'b ) format4 -> 'a +val fail_lex : Lexing.lexbuf -> ('a, Format.formatter, unit, 'b ) format4 -> 'a +val fail_opt : Loc.t option -> ('a, Format.formatter, unit, 'b ) format4 -> 'a + +(** Prints "File ..., line ..., characters ...:\n" *) +val print : Format.formatter -> Loc.t -> unit + +(** Prints a warning *) +val warn : Loc.t -> ('a, Format.formatter, unit) format -> 'a + +val print_to_console : string -> unit + +val printer : (string -> unit) ref diff --git a/src/exe.ml b/src/exe.ml index 5fa3ede2..2deb3659 100644 --- a/src/exe.ml +++ b/src/exe.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Build.O diff --git a/src/fiber/fiber.ml b/src/fiber/fiber.ml index e8793d81..b7be3abb 100644 --- a/src/fiber/fiber.ml +++ b/src/fiber/fiber.ml @@ -1,4 +1,4 @@ -open Stdune +open! Stdune module Execution_context : sig type t @@ -234,7 +234,7 @@ module Var = struct fiber ctx k let create () = - create ~name:"var" (fun _ -> Sexp.atom_or_quoted_string "var") + create ~name:"var" (fun _ -> Sexp.To_sexp.string "var") end let with_error_handler f ~on_error ctx k = diff --git a/src/fiber/fiber.mli b/src/fiber/fiber.mli index d1c7851d..46ae01e2 100644 --- a/src/fiber/fiber.mli +++ b/src/fiber/fiber.mli @@ -1,6 +1,6 @@ (** Concurrency library *) -open Stdune +open! Stdune (** {1 Generals} *) diff --git a/src/file_tree.ml b/src/file_tree.ml index 6cdab804..51e66c12 100644 --- a/src/file_tree.ml +++ b/src/file_tree.ml @@ -1,8 +1,9 @@ +open! Stdune open! Import module Dune_file = struct module Kind = struct - type t = Usexp.syntax = Jbuild | Dune + type t = Dsexp.syntax = Jbuild | Dune let of_basename = function | "dune" -> Dune @@ -10,14 +11,14 @@ module Dune_file = struct | _ -> assert false let lexer = function - | Dune -> Sexp.Lexer.token - | Jbuild -> Sexp.Lexer.jbuild_token + | Dune -> Dsexp.Lexer.token + | Jbuild -> Dsexp.Lexer.jbuild_token end module Plain = struct type t = { path : Path.t - ; mutable sexps : Sexp.Ast.t list + ; mutable sexps : Dsexp.Ast.t list } end @@ -39,7 +40,7 @@ module Dune_file = struct let extract_ignored_subdirs = let stanza = - let open Sexp.Of_sexp in + let open Dsexp.Of_sexp in let sub_dir = plain_string (fun ~loc dn -> if Filename.dirname dn <> Filename.current_dir_name || @@ -58,9 +59,9 @@ module Dune_file = struct fun sexps -> let ignored_subdirs, sexps = List.partition_map sexps ~f:(fun sexp -> - match (sexp : Sexp.Ast.t) with + match (sexp : Dsexp.Ast.t) with | List (_, (Atom (_, A "ignored_subdirs") :: _)) -> - Left (Sexp.Of_sexp.parse stanza Univ_map.empty sexp) + Left (Dsexp.Of_sexp.parse stanza Univ_map.empty sexp) | _ -> Right sexp) in let ignored_subdirs = @@ -75,7 +76,7 @@ module Dune_file = struct (Contents.Ocaml_script file, String.Set.empty) else let sexps = - Usexp.Parser.parse lb ~lexer:(Kind.lexer kind) ~mode:Many + Dsexp.Parser.parse lb ~lexer:(Kind.lexer kind) ~mode:Many in let ignored_subdirs, sexps = extract_ignored_subdirs sexps in (Plain { path = file; sexps }, ignored_subdirs) @@ -88,11 +89,12 @@ let load_jbuild_ignore path = if Filename.dirname fn = Filename.current_dir_name then true else begin - Loc.(warn (of_pos ( Path.to_string path - , i + 1, 0 - , String.length fn - )) - "subdirectory expression %s ignored" fn); + Errors.(warn (Loc.of_pos + ( Path.to_string path + , i + 1, 0 + , String.length fn + )) + "subdirectory expression %s ignored" fn); false end) |> String.Set.of_list diff --git a/src/file_tree.mli b/src/file_tree.mli index 022e9059..342883c0 100644 --- a/src/file_tree.mli +++ b/src/file_tree.mli @@ -1,12 +1,13 @@ +open! Stdune (** Dune representation of the source tree *) open! Import module Dune_file : sig module Kind : sig - type t = Usexp.syntax = Jbuild | Dune + type t = Dsexp.syntax = Jbuild | Dune - val lexer : t -> Sexp.Lexer.t + val lexer : t -> Dsexp.Lexer.t end module Plain : sig @@ -15,7 +16,7 @@ module Dune_file : sig as we don't need them. *) type t = { path : Path.t - ; mutable sexps : Sexp.Ast.t list + ; mutable sexps : Dsexp.Ast.t list } end diff --git a/src/findlib.ml b/src/findlib.ml index 30e8c3a1..9c3ceaad 100644 --- a/src/findlib.ml +++ b/src/findlib.ml @@ -1,3 +1,4 @@ +open! Stdune open Import module P = Variant diff --git a/src/findlib.mli b/src/findlib.mli index 83875550..c098469b 100644 --- a/src/findlib.mli +++ b/src/findlib.mli @@ -1,5 +1,6 @@ (** Findlib database *) +open! Stdune open Import (** Findlib database *) diff --git a/src/gen_meta.ml b/src/gen_meta.ml index 7931e87e..31e631b5 100644 --- a/src/gen_meta.ml +++ b/src/gen_meta.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Meta diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 5f56de34..08563dc9 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -1,3 +1,4 @@ +open! Stdune open Import module Menhir_rules = Menhir open Dune_file @@ -61,11 +62,11 @@ module Gen(P : Install_rules.Params) = struct match Module.Name.Map.find modules mod_name with | Some m -> if not (Module.has_impl m) then - Loc.fail loc "Module %a has no implementation." + Errors.fail loc "Module %a has no implementation." Module.Name.pp mod_name else { Exe.Program.name; main_module_name = mod_name } - | None -> Loc.fail loc "Module %a doesn't exist." + | None -> Errors.fail loc "Module %a doesn't exist." Module.Name.pp mod_name) in @@ -295,7 +296,7 @@ module Gen(P : Install_rules.Params) = struct SC.add_rule sctx (Build.fail ~targets { fail = fun () -> - Loc.fail m.loc + Errors.fail m.loc "I can't determine what library/executable the files \ produced by this stanza are part of." }) diff --git a/src/gen_rules.mli b/src/gen_rules.mli index 26bb473d..ca95fa87 100644 --- a/src/gen_rules.mli +++ b/src/gen_rules.mli @@ -1,3 +1,4 @@ +open! Stdune open! Import (* Generate rules. Returns evaluated jbuilds per context names. *) diff --git a/src/glob_lexer.mli b/src/glob_lexer.mli index 79611c4e..6f626ada 100644 --- a/src/glob_lexer.mli +++ b/src/glob_lexer.mli @@ -1,3 +1,3 @@ -open Import +open Stdune -val parse_string : string -> (Re.t, int * string) result +val parse_string : string -> (Re.t, int * string) Result.result diff --git a/src/glob_lexer.mll b/src/glob_lexer.mll index bbfd0fc3..089490db 100644 --- a/src/glob_lexer.mll +++ b/src/glob_lexer.mll @@ -1,4 +1,5 @@ { +open! Stdune open Re let no_slash = diff any (char '/') @@ -59,8 +60,8 @@ and char_set st = parse let parse_string s = let lb = Lexing.from_string s in match initial lb with - | re -> Import.Ok re + | re -> Result.Ok re | exception Failure msg -> - Import.Error (Lexing.lexeme_start lb, msg) + Error (Lexing.lexeme_start lb, msg) } diff --git a/src/import.ml b/src/import.ml index b78b4176..bff4f735 100644 --- a/src/import.ml +++ b/src/import.ml @@ -1,3 +1,5 @@ +open! Stdune + include Stdune include Errors @@ -87,6 +89,4 @@ module No_io = struct module Io = struct end end -(* This is ugly *) -let printer = ref (Printf.eprintf "%s%!") -let print_to_console s = !printer s +let print_to_console = Errors.print_to_console diff --git a/src/inline_tests.ml b/src/inline_tests.ml index 55d07341..0703011a 100644 --- a/src/inline_tests.ml +++ b/src/inline_tests.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Dune_file open Build.O @@ -37,7 +38,7 @@ module Backend = struct (let%map loc = loc and runner_libraries = field "runner_libraries" (list (located string)) ~default:[] and flags = Ordered_set_lang.Unexpanded.field "flags" - and generate_runner = field_o "generate_runner" (located Action.Unexpanded.t) + and generate_runner = field_o "generate_runner" (located Action.Unexpanded.dparse) and extends = field "extends" (list (located string)) ~default:[] in { loc @@ -74,21 +75,21 @@ module Backend = struct resolve x >>= fun lib -> match get ~loc lib with | None -> - Error (Loc.exnf loc "%S is not an %s" name + Error (Errors.exnf loc "%S is not an %s" name (desc ~plural:false)) | Some t -> Ok t)) } - let to_sexp t = - let open Sexp.To_sexp in + let dgen t = + let open Dsexp.To_sexp in let lib x = string (Lib.name x) in let f x = string (Lib.name x.lib) in ((1, 0), record_fields [ field "runner_libraries" (list lib) (Result.ok_exn t.runner_libraries) - ; field "flags" Ordered_set_lang.Unexpanded.sexp_of_t t.info.flags - ; field_o "generate_runner" Action.Unexpanded.sexp_of_t + ; field "flags" Ordered_set_lang.Unexpanded.dgen t.info.flags + ; field_o "generate_runner" Action.Unexpanded.dgen (Option.map t.info.generate_runner ~f:snd) ; field "extends" (list f) (Result.ok_exn t.extends) ~default:[] ]) @@ -135,7 +136,7 @@ include Sub_system.Register_end_point( ~else_: (record (let%map loc = loc - and deps = field "deps" (list Dep_conf.t) ~default:[] + and deps = field "deps" (list Dep_conf.dparse) ~default:[] and flags = Ordered_set_lang.Unexpanded.field "flags" and backend = field_o "backend" (located string) and libraries = field "libraries" (list (located string)) ~default:[] @@ -260,9 +261,7 @@ include Sub_system.Register_end_point( SC.add_alias_action sctx ~loc:(Some info.loc) (Build_system.Alias.runtest ~dir) - ~stamp:(List [ Sexp.unsafe_atom_of_string "ppx-runner" - ; Quoted_string name - ]) + ~stamp:("ppx-runner", name) (let module A = Action in let exe = Path.relative inline_test_dir (name ^ ".exe") in Build.path exe >>> diff --git a/src/install.ml b/src/install.ml index 1609b704..e6297d8e 100644 --- a/src/install.ml +++ b/src/install.ml @@ -1,3 +1,4 @@ +open! Stdune open Import module Section = struct @@ -58,8 +59,8 @@ module Section = struct |"misc" -> Some Misc | _ -> None - let t = - let open Sexp.Of_sexp in + let dparse = + let open Dsexp.Of_sexp in enum [ "lib" , Lib ; "lib_root" , Lib_root @@ -271,7 +272,7 @@ let load_install_file path = ; pos_cnum = col } in - Loc.fail { start = pos; stop = pos } fmt + Errors.fail { start = pos; stop = pos } fmt in List.concat_map file.file_contents ~f:(function | Variable (pos, section, files) -> begin diff --git a/src/install.mli b/src/install.mli index 2ce0920a..8023c6f5 100644 --- a/src/install.mli +++ b/src/install.mli @@ -1,6 +1,6 @@ (** Opam install file *) -open Stdune +open! Stdune module Section : sig type t = @@ -19,7 +19,7 @@ module Section : sig | Man | Misc - val t : t Sexp.Of_sexp.t + val dparse : t Dsexp.Of_sexp.t (** [true] iff the executable bit should be set for files installed in this location. *) diff --git a/src/install_rules.ml b/src/install_rules.ml index d5886fad..5102f77e 100644 --- a/src/install_rules.ml +++ b/src/install_rules.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Dune_file open Build.O @@ -22,7 +23,7 @@ module Gen(P : Params) = struct (Build.arr (fun () -> let dune_version = Option.value_exn (Lib.dune_version lib) in Format.asprintf "%a@." - (Sexp.pp (Stanza.File_kind.of_syntax dune_version)) + (Dsexp.pp (Stanza.File_kind.of_syntax dune_version)) (Lib.Sub_system.dump_config lib |> Installed_dune_file.gen ~dune_version)) >>> Build.write_file_dyn diff --git a/src/installed_dune_file.ml b/src/installed_dune_file.ml index 43fd6e83..89ad3a72 100644 --- a/src/installed_dune_file.ml +++ b/src/installed_dune_file.ml @@ -1,9 +1,9 @@ -open Import +open! Stdune let parse_sub_systems ~parsing_context sexps = List.filter_map sexps ~f:(fun sexp -> let name, ver, data = - Sexp.Of_sexp.(parse (triple string (located Syntax.Version.t) raw) + Dsexp.Of_sexp.(parse (triple string (located Syntax.Version.dparse) raw) parsing_context) sexp in match Sub_system_name.get name with @@ -12,12 +12,12 @@ let parse_sub_systems ~parsing_context sexps = correspond to plugins that are not in use in the current workspace. *) None - | Some name -> Some (name, (Sexp.Ast.loc sexp, ver, data))) + | Some name -> Some (name, (Dsexp.Ast.loc sexp, ver, data))) |> Sub_system_name.Map.of_list |> (function | Ok x -> x | Error (name, _, (loc, _, _)) -> - Loc.fail loc "%S present twice" (Sub_system_name.to_string name)) + Errors.fail loc "%S present twice" (Sub_system_name.to_string name)) |> Sub_system_name.Map.mapi ~f:(fun name (_, version, data) -> let (module M) = Dune_file.Sub_system_info.get name in Syntax.check_supported M.syntax version; @@ -32,10 +32,10 @@ let parse_sub_systems ~parsing_context sexps = | (_, _) -> Univ_map.add parsing_context (Syntax.key M.syntax) (snd version) in - M.T (Sexp.Of_sexp.parse M.parse parsing_context data)) + M.T (Dsexp.Of_sexp.parse M.parse parsing_context data)) let of_sexp = - let open Sexp.Of_sexp in + let open Dsexp.Of_sexp in let version = plain_string (fun ~loc -> function | "1" -> (0, 0) @@ -64,45 +64,45 @@ let load fname = which point we can decide what lexer to use for the reset of the file. *) let state = ref 0 in - let lexer = ref Sexp.Lexer.token in + let lexer = ref Dsexp.Lexer.token in let lexer lb = - let token : Sexp.Lexer.Token.t = !lexer lb in + let token : Dsexp.Lexer.Token.t = !lexer lb in (match !state, token with | 0, Lparen -> state := 1 | 1, Atom (A "dune") -> state := 2 - | 2, Atom (A "1") -> state := 3; lexer := Sexp.Lexer.jbuild_token - | 2, Atom (A "2") -> state := 3; lexer := Sexp.Lexer.token + | 2, Atom (A "1") -> state := 3; lexer := Dsexp.Lexer.jbuild_token + | 2, Atom (A "2") -> state := 3; lexer := Dsexp.Lexer.token | 2, Atom (A version) -> - Loc.fail (Sexp.Loc.of_lexbuf lexbuf) "Unsupported version %S" version + Errors.fail (Loc.of_lexbuf lexbuf) "Unsupported version %S" version | 3, _ -> () | _ -> - Loc.fail (Sexp.Loc.of_lexbuf lexbuf) + Errors.fail (Loc.of_lexbuf lexbuf) "This .dune file looks invalid, it should \ contain a S-expression of the form (dune x.y ..)" ); token in - Sexp.Of_sexp.parse of_sexp Univ_map.empty - (Sexp.Parser.parse ~lexer ~mode:Single lexbuf)) + Dsexp.Of_sexp.parse of_sexp Univ_map.empty + (Dsexp.Parser.parse ~lexer ~mode:Single lexbuf)) let gen ~(dune_version : Syntax.Version.t) confs = let sexps = Sub_system_name.Map.to_list confs |> List.map ~f:(fun (name, (ver, conf)) -> let (module M) = Dune_file.Sub_system_info.get name in - Sexp.List [ Sexp.atom (Sub_system_name.to_string name) - ; Syntax.Version.sexp_of_t ver + Dsexp.List [ Dsexp.atom (Sub_system_name.to_string name) + ; Syntax.Version.dgen ver ; conf ]) in - Sexp.List - [ Sexp.unsafe_atom_of_string "dune" - ; Sexp.unsafe_atom_of_string + Dsexp.List + [ Dsexp.unsafe_atom_of_string "dune" + ; Dsexp.unsafe_atom_of_string (match dune_version with | (0, 0) -> "1" | (x, _) when x >= 1 -> "2" | (_, _) -> Exn.code_error "Cannot generate dune with unknown version" - ["dune_version", Syntax.Version.sexp_of_t dune_version]) + ["dune_version", Syntax.Version.to_sexp dune_version]) ; List sexps ] diff --git a/src/installed_dune_file.mli b/src/installed_dune_file.mli index 3f6caa5f..a8ce17cb 100644 --- a/src/installed_dune_file.mli +++ b/src/installed_dune_file.mli @@ -1,9 +1,9 @@ (** Dune files that are installed on the system *) -open Stdune +open! Stdune val load : Path.t -> Dune_file.Sub_system_info.t Sub_system_name.Map.t val gen : dune_version:Syntax.Version.t - -> (Syntax.Version.t * Sexp.t) Sub_system_name.Map.t - -> Sexp.t + -> (Syntax.Version.t * Dsexp.t) Sub_system_name.Map.t + -> Dsexp.t diff --git a/src/jbuild_load.ml b/src/jbuild_load.ml index dee5569a..4f1c52f6 100644 --- a/src/jbuild_load.ml +++ b/src/jbuild_load.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Dune_file @@ -73,7 +74,7 @@ module Jbuilds = struct (match (kind : File_tree.Dune_file.Kind.t) with | Jbuild -> () | Dune -> - Loc.fail loc + Errors.fail loc "#require is no longer supported in dune files.\n\ You can use the following function instead of \ Unix.open_process_in:\n\ @@ -84,7 +85,7 @@ module Jbuilds = struct | [] -> acc | ["unix"] -> Unix | _ -> - Loc.fail loc + Errors.fail loc "Using libraries other that \"unix\" is not supported.\n\ See the manual for details."; in @@ -207,7 +208,7 @@ end Did you forgot to call [Jbuild_plugin.V*.send]?" (Path.to_string file); Fiber.return - (Io.Sexp.load generated_jbuild ~mode:Many + (Dsexp.Io.load generated_jbuild ~mode:Many ~lexer:(File_tree.Dune_file.Kind.lexer kind) |> Jbuild.parse ~dir ~file ~project ~kind ~ignore_promoted_rules)) >>| fun dynamic -> diff --git a/src/jbuild_load.mli b/src/jbuild_load.mli index 17c8214e..cbd2ec18 100644 --- a/src/jbuild_load.mli +++ b/src/jbuild_load.mli @@ -1,4 +1,4 @@ -open Stdune +open! Stdune module Jbuild : sig type t = diff --git a/src/js_of_ocaml_rules.ml b/src/js_of_ocaml_rules.ml index f65c1cc8..d2f9c611 100644 --- a/src/js_of_ocaml_rules.ml +++ b/src/js_of_ocaml_rules.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open! No_io open Build.O diff --git a/src/js_of_ocaml_rules.mli b/src/js_of_ocaml_rules.mli index 8f5ad23c..66784593 100644 --- a/src/js_of_ocaml_rules.mli +++ b/src/js_of_ocaml_rules.mli @@ -1,5 +1,6 @@ (** Generate rules for js_of_ocaml *) +open! Stdune open Import open Dune_file diff --git a/src/lib.ml b/src/lib.ml index d9cde3bc..89ebaa00 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -1,4 +1,5 @@ open Import +open! Stdune open Result.O (* +-----------------------------------------------------------------+ @@ -202,7 +203,7 @@ module Sub_system0 = struct module type S = sig type t type sub_system += T of t - val to_sexp : (t -> Syntax.Version.t * Sexp.t) option + val dgen : (t -> Syntax.Version.t * Dsexp.t) option end type 'a s = (module S with type t = 'a) @@ -319,7 +320,7 @@ exception Error of Error.t let not_available ~loc reason fmt = Errors.kerrf fmt ~f:(fun s -> - Loc.fail loc "%s %a" s + Errors.fail loc "%s %a" s Error.Library_not_available.Reason.pp reason) (* +-----------------------------------------------------------------+ @@ -455,7 +456,7 @@ module Sub_system = struct -> lib -> Info.t -> t - val to_sexp : (t -> Syntax.Version.t * Sexp.t) option + val dgen : (t -> Syntax.Version.t * Dsexp.t) option end module type S' = sig @@ -491,7 +492,7 @@ module Sub_system = struct | M.Info.T info -> let get ~loc lib' = if lib.unique_id = lib'.unique_id then - Loc.fail loc "Library %S depends on itself" lib.name + Errors.fail loc "Library %S depends on itself" lib.name else M.get lib' in @@ -502,7 +503,7 @@ module Sub_system = struct let dump_config lib = Sub_system_name.Map.filter_map lib.sub_systems ~f:(fun (lazy inst) -> let (Sub_system0.Instance.T ((module M), t)) = inst in - Option.map ~f:(fun f -> f t) M.to_sexp) + Option.map ~f:(fun f -> f t) M.dgen) end (* +-----------------------------------------------------------------+ @@ -582,25 +583,25 @@ let check_private_deps lib ~loc ~allow_private_deps = Ok lib let already_in_table (info : Info.t) name x = - let to_sexp = Sexp.To_sexp.(pair Path.sexp_of_t string) in + let dgen = Sexp.To_sexp.(pair Path.to_sexp string) in let sexp = match x with | St_initializing x -> - Sexp.List [Sexp.unsafe_atom_of_string "Initializing"; - Path.sexp_of_t x.path] + Sexp.List [Sexp.Atom "Initializing"; + Path.to_sexp x.path] | St_found t -> - List [Sexp.unsafe_atom_of_string "Found"; - Path.sexp_of_t t.info.src_dir] + List [Sexp.Atom "Found"; + Path.to_sexp t.info.src_dir] | St_not_found -> - Sexp.unsafe_atom_of_string "Not_found" + Sexp.Atom "Not_found" | St_hidden (_, { path; reason; _ }) -> - List [Sexp.unsafe_atom_of_string "Hidden"; - Path.sexp_of_t path; Sexp.atom reason] + List [Sexp.Atom "Hidden"; + Path.to_sexp path; Sexp.Atom reason] in Exn.code_error "Lib_db.DB: resolver returned name that's already in the table" - [ "name" , Sexp.atom name - ; "returned_lib" , to_sexp (info.src_dir, name) + [ "name" , Sexp.To_sexp.string name + ; "returned_lib" , dgen (info.src_dir, name) ; "conflicting_with", sexp ] @@ -1137,7 +1138,7 @@ let report_lib_error ppf (e : Error.t) = | No_solution_found_for_select { loc } -> Format.fprintf ppf "%a@{Error@}: No solution found for this select form.\n" - Loc.print loc + Errors.print loc | Dependency_cycle cycle -> Format.fprintf ppf "@{Error@}: Dependency cycle detected between the \ diff --git a/src/lib.mli b/src/lib.mli index f4748754..bfb43aec 100644 --- a/src/lib.mli +++ b/src/lib.mli @@ -1,3 +1,4 @@ +open! Stdune open Import (** {1 Generals} *) @@ -331,7 +332,7 @@ module Sub_system : sig -> lib -> Info.t -> t - val to_sexp : (t -> Syntax.Version.t * Sexp.t) option + val dgen : (t -> Syntax.Version.t * Dsexp.t) option end module Register(M : S) : sig @@ -339,7 +340,7 @@ module Sub_system : sig val get : lib -> M.t option end - val dump_config : lib -> (Syntax.Version.t * Sexp.t) Sub_system_name.Map.t + val dump_config : lib -> (Syntax.Version.t * Dsexp.t) Sub_system_name.Map.t end with type lib := t (** {1 Dependencies for META files} *) diff --git a/src/lib_deps_info.ml b/src/lib_deps_info.ml index a59fc279..51891671 100644 --- a/src/lib_deps_info.ml +++ b/src/lib_deps_info.ml @@ -1,4 +1,4 @@ -open Import +open! Stdune module Kind = struct type t = diff --git a/src/lib_deps_info.mli b/src/lib_deps_info.mli index fbcf1540..4983b88a 100644 --- a/src/lib_deps_info.mli +++ b/src/lib_deps_info.mli @@ -3,7 +3,7 @@ (** This module implements tracking of external library dependencies, for [dune external-lib-deps] *) -open Import +open! Stdune module Kind : sig type t = diff --git a/src/lib_rules.ml b/src/lib_rules.ml index bb013af9..a3761ea5 100644 --- a/src/lib_rules.ml +++ b/src/lib_rules.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Build.O open Dune_file @@ -226,7 +227,7 @@ module Gen (P : Install_rules.Params) = struct if not (match Path.parent p with | None -> false | Some p -> Path.Set.mem all_dirs p) then - Loc.fail loc + Errors.fail loc "File %a is not part of the current directory group. \ This is not allowed." Path.pp (Path.drop_optional_build_context p) diff --git a/src/lib_rules.mli b/src/lib_rules.mli index 45c270ee..0e487e5a 100644 --- a/src/lib_rules.mli +++ b/src/lib_rules.mli @@ -1,4 +1,4 @@ -open Stdune +open! Stdune open Dune_file module Gen (S : sig val sctx : Super_context.t end) : sig @@ -13,6 +13,6 @@ module Gen (S : sig val sctx : Super_context.t end) : sig -> dir_contents:Dir_contents.t -> dir:Path.t -> scope:Scope.t - -> dir_kind:Usexp.syntax + -> dir_kind:Dsexp.syntax -> Compilation_context.t * Merlin.t end diff --git a/src/loc.ml b/src/loc.ml deleted file mode 100644 index a1d5a614..00000000 --- a/src/loc.ml +++ /dev/null @@ -1,146 +0,0 @@ -open Import - -include Usexp.Loc - -(* TODO get rid of all this stuff once this parsing code moves to Usexp and - there will be no circular dependency *) -let int n = Usexp.Atom (Usexp.Atom.of_int n) -let string = Usexp.atom_or_quoted_string -let record l = - let open Usexp in - List (List.map l ~f:(fun (n, v) -> List [Atom(Atom.of_string n); v])) - -let sexp_of_position_no_file (p : Lexing.position) = - record - [ "pos_lnum", int p.pos_lnum - ; "pos_bol", int p.pos_bol - ; "pos_cnum", int p.pos_cnum - ] - -let sexp_of_t t = - record (* TODO handle when pos_fname differs *) - [ "pos_fname", string t.start.pos_fname - ; "start", sexp_of_position_no_file t.start - ; "stop", sexp_of_position_no_file t.stop - ] - -let of_lexbuf lb = - { start = Lexing.lexeme_start_p lb - ; stop = Lexing.lexeme_end_p lb - } - -let exnf t fmt = - Format.pp_open_box err_ppf 0; - Format.pp_print_as err_ppf 7 ""; (* "Error: " *) - kerrf (fmt^^ "@]") ~f:(fun s -> Exn.Loc_error (t, s)) - -let fail t fmt = - Format.pp_print_as err_ppf 7 ""; (* "Error: " *) - kerrf fmt ~f:(fun s -> - raise (Exn.Loc_error (t, s))) - -let fail_lex lb fmt = - fail (of_lexbuf lb) fmt - -let fail_opt t fmt = - match t with - | None -> die fmt - | Some t -> fail t fmt - -let in_file = Usexp.Loc.in_file - -let of_pos (fname, lnum, cnum, enum) = - let pos : Lexing.position = - { pos_fname = fname - ; pos_lnum = lnum - ; pos_cnum = cnum - ; pos_bol = 0 - } - in - { start = pos - ; stop = { pos with pos_cnum = enum } - } - -let file_line path n = - Io.with_file_in ~binary:false path - ~f:(fun ic -> - for _ = 1 to n - 1 do - ignore (input_line ic) - done; - input_line ic - ) - -let file_lines path ~start ~stop = - Io.with_file_in ~binary:true path - ~f:(fun ic -> - let rec aux acc lnum = - if lnum > stop then - List.rev acc - else if lnum < start then - (ignore (input_line ic); - aux acc (lnum + 1)) - else - let line = input_line ic in - aux ((string_of_int lnum, line) :: acc) (lnum + 1) - in - aux [] 1 - ) - -let print ppf loc = - let { start; stop } = loc in - let start_c = start.pos_cnum - start.pos_bol in - let stop_c = stop.pos_cnum - start.pos_bol in - let num_lines = stop.pos_lnum - start.pos_lnum in - let pp_file_excerpt pp () = - let whole_file = start_c = 0 && stop_c = 0 in - if not whole_file then - let path = Path.of_string start.pos_fname in - if Path.exists path then - let line = file_line path start.pos_lnum in - if stop_c <= String.length line then - let len = stop_c - start_c in - Format.fprintf pp "%s\n%*s\n" line - stop_c - (String.make len '^') - else if num_lines <= 10 then - let lines = file_lines path ~start:start.pos_lnum ~stop:stop.pos_lnum in - let last_lnum = Option.map ~f:fst (List.last lines) in - let padding_width = Option.value_exn - (Option.map ~f:String.length last_lnum) in - List.iter ~f:(fun (lnum, l) -> - Format.fprintf pp "%*s: %s\n" padding_width lnum l) - lines - in - Format.fprintf ppf - "@{File \"%s\", line %d, characters %d-%d:@}@\n%a" - start.pos_fname start.pos_lnum start_c stop_c - pp_file_excerpt () - -let warn t fmt = - Errors.kerrf ~f:print_to_console - ("%a@{Warning@}: " ^^ fmt ^^ "@.") print t - -let to_file_colon_line t = - sprintf "%s:%d" t.start.pos_fname t.start.pos_lnum - -let pp_file_colon_line ppf t = - Format.pp_print_string ppf (to_file_colon_line t) - -let equal_position - { Lexing.pos_fname = f_a; pos_lnum = l_a - ; pos_bol = b_a; pos_cnum = c_a } - { Lexing.pos_fname = f_b; pos_lnum = l_b - ; pos_bol = b_b; pos_cnum = c_b } - = - let open Int.Infix in - String.equal f_a f_b - && l_a = l_b - && b_a = b_b - && c_a = c_b - -let equal - { start = start_a ; stop = stop_a } - { start = start_b ; stop = stop_b } - = - equal_position start_a start_b - && equal_position stop_a stop_b diff --git a/src/loc.mli b/src/loc.mli deleted file mode 100644 index 053030ed..00000000 --- a/src/loc.mli +++ /dev/null @@ -1,31 +0,0 @@ -type t = Usexp.Loc.t = - { start : Lexing.position - ; stop : Lexing.position - } - -val equal : t -> t -> bool - -val sexp_of_t : t -> Usexp.t - -val of_lexbuf : Lexing.lexbuf -> t - -val exnf : t -> ('a, Format.formatter, unit, exn) format4 -> 'a -val fail : t -> ('a, Format.formatter, unit, 'b ) format4 -> 'a -val fail_lex : Lexing.lexbuf -> ('a, Format.formatter, unit, 'b ) format4 -> 'a -val fail_opt : t option -> ('a, Format.formatter, unit, 'b ) format4 -> 'a - -val in_file : string -> t - -(** To be used with [__POS__] *) -val of_pos : (string * int * int * int) -> t - -val none : t - -val to_file_colon_line : t -> string -val pp_file_colon_line : Format.formatter -> t -> unit - -(** Prints "File ..., line ..., characters ...:\n" *) -val print : Format.formatter -> t -> unit - -(** Prints a warning *) -val warn : t -> ('a, Format.formatter, unit) format -> 'a diff --git a/src/log.ml b/src/log.ml index 823d36f6..13913a89 100644 --- a/src/log.ml +++ b/src/log.ml @@ -1,3 +1,4 @@ +open! Stdune open Import type real = diff --git a/src/main.ml b/src/main.ml index 563bb740..dbeab71f 100644 --- a/src/main.ml +++ b/src/main.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Fiber.O @@ -78,8 +79,8 @@ let setup ?(log=Log.no_log) >>= fun contexts -> let contexts = List.concat contexts in List.iter contexts ~f:(fun (ctx : Context.t) -> - Log.infof log "@[<1>Dune context:@,%a@]@." (Sexp.pp Dune) - (Context.sexp_of_t ctx)); + Log.infof log "@[<1>Dune context:@,%a@]@." Sexp.pp + (Context.to_sexp ctx)); let rule_done = ref 0 in let rule_total = ref 0 in let gen_status_line () = diff --git a/src/main.mli b/src/main.mli index a7cfbc8b..92649c00 100644 --- a/src/main.mli +++ b/src/main.mli @@ -1,3 +1,4 @@ +open! Stdune open! Import type setup = diff --git a/src/merlin.ml b/src/merlin.ml index 1a7ef73d..d3ba58c0 100644 --- a/src/merlin.ml +++ b/src/merlin.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Build.O open! No_io diff --git a/src/merlin.mli b/src/merlin.mli index 5e0eb696..3902f999 100644 --- a/src/merlin.mli +++ b/src/merlin.mli @@ -1,5 +1,6 @@ (** Merlin rules *) +open! Stdune open Import type t diff --git a/src/meta.ml b/src/meta.ml index fe7713f5..f26722fb 100644 --- a/src/meta.ml +++ b/src/meta.ml @@ -1,3 +1,4 @@ +open! Stdune open Import type t = @@ -24,7 +25,7 @@ and predicate = | Neg of string module Parse = struct - let error = Loc.fail_lex + let error = Errors.fail_lex let next = Meta_lexer.token diff --git a/src/meta.mli b/src/meta.mli index 8c38f9da..ee617489 100644 --- a/src/meta.mli +++ b/src/meta.mli @@ -1,5 +1,6 @@ (** META file parsing/printing *) +open! Stdune open! Import type t = diff --git a/src/meta_lexer.mll b/src/meta_lexer.mll index 1ca4156e..5f4ca850 100644 --- a/src/meta_lexer.mll +++ b/src/meta_lexer.mll @@ -29,7 +29,7 @@ rule token = parse | '=' { Equal } | "+=" { Plus_equal } | eof { Eof } - | _ { Loc.fail_lex lexbuf "invalid character" } + | _ { Errors.fail_lex lexbuf "invalid character" } and string buf = parse | '"' @@ -44,4 +44,4 @@ and string buf = parse { Buffer.add_char buf c; string buf lexbuf } | eof - { Loc.fail_lex lexbuf "unterminated string" } + { Errors.fail_lex lexbuf "unterminated string" } diff --git a/src/mode.ml b/src/mode.ml index fef3d670..53dd99a9 100644 --- a/src/mode.ml +++ b/src/mode.ml @@ -1,11 +1,12 @@ +open! Stdune open! Import type t = Byte | Native let all = [Byte; Native] -let t = - let open Sexp.Of_sexp in +let dparse = + let open Dsexp.Of_sexp in enum [ "byte" , Byte ; "native" , Native @@ -73,7 +74,7 @@ module Dict = struct ; native = List.mem Native ~set:l } - let t = Sexp.Of_sexp.(map (list t) ~f:of_list) + let dparse = Dsexp.Of_sexp.(map (list dparse) ~f:of_list) let is_empty t = not (t.byte || t.native) diff --git a/src/mode.mli b/src/mode.mli index d87542ca..2ae6df44 100644 --- a/src/mode.mli +++ b/src/mode.mli @@ -2,7 +2,7 @@ open! Import type t = Byte | Native -val t : t Sexp.Of_sexp.t +val dparse : t Dsexp.Of_sexp.t val all : t list @@ -35,7 +35,7 @@ module Dict : sig module Set : sig type nonrec t = bool t - val t : t Sexp.Of_sexp.t + val dparse : t Dsexp.Of_sexp.t val all : t val is_empty : t -> bool val to_list : t -> mode list diff --git a/src/module.ml b/src/module.ml index 7bc804d4..645c2ff6 100644 --- a/src/module.ml +++ b/src/module.ml @@ -1,3 +1,4 @@ +open! Stdune open Import module Name = struct @@ -8,7 +9,10 @@ module Name = struct include T - let t = Sexp.atom + let dparse = Dsexp.Of_sexp.string + let dgen = Dsexp.To_sexp.string + + let to_sexp = Sexp.To_sexp.string let add_suffix = (^) diff --git a/src/module.mli b/src/module.mli index 8f5b4727..94dbeb8c 100644 --- a/src/module.mli +++ b/src/module.mli @@ -1,11 +1,14 @@ +open! Stdune open! Import module Name : sig type t + include Dsexp.Sexpable with type t := t + val add_suffix : t -> string -> t - val t : t Sexp.To_sexp.t + val to_sexp : t Sexp.To_sexp.t val compare : t -> t -> Ordering.t val of_string : string -> t val to_string : t -> string diff --git a/src/module_compilation.ml b/src/module_compilation.ml index a504e0a4..6f12d604 100644 --- a/src/module_compilation.ml +++ b/src/module_compilation.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Build.O open! No_io diff --git a/src/ocaml-config/dune b/src/ocaml-config/dune index f32f26cf..1e97fd5f 100644 --- a/src/ocaml-config/dune +++ b/src/ocaml-config/dune @@ -1,5 +1,5 @@ (library (name ocaml_config) (public_name dune._ocaml_config) - (libraries stdune usexp) + (libraries stdune) (synopsis "[Internal] Interpret the output of 'ocamlc -config'")) diff --git a/src/ocaml-config/ocaml_config.ml b/src/ocaml-config/ocaml_config.ml index 7157b204..9af769e5 100644 --- a/src/ocaml-config/ocaml_config.ml +++ b/src/ocaml-config/ocaml_config.ml @@ -1,4 +1,4 @@ -open Stdune +open! Stdune open Result.O module Prog_and_args = struct @@ -17,14 +17,15 @@ module Value = struct | Words of string list | Prog_and_args of Prog_and_args.t - let sexp_of_t : t -> Usexp.t = function - | Bool x -> Atom (Usexp.Atom.of_bool x) - | Int x -> Atom (Usexp.Atom.of_int x) - | String x -> Usexp.atom_or_quoted_string x - | Words x -> List (List.map x ~f:Usexp.atom_or_quoted_string) - | Prog_and_args x -> - List (Usexp.atom_or_quoted_string x.prog - :: List.map x.args ~f:Usexp.atom_or_quoted_string) + let to_sexp : t -> Sexp.t = + let open Sexp.To_sexp in + function + | Bool x -> bool x + | Int x -> int x + | String x -> string x + | Words x -> (list string) x + | Prog_and_args { prog; args } -> + (list string) (prog :: args) let to_string = function | Bool x -> string_of_bool x @@ -184,13 +185,14 @@ let to_list t : (string * Value.t) list = ; "supports_shared_libraries", Bool t.supports_shared_libraries ] -let sexp_of_t t = - Usexp.List +let to_sexp t = + let open Sexp in + List (to_list t |> List.map ~f:(fun (k, v) -> - Usexp.List [ Usexp.atom_or_quoted_string k - ; Value.sexp_of_t v - ])) + List [ Atom k + ; Value.to_sexp v + ])) module Origin = struct type t = diff --git a/src/ocaml-config/ocaml_config.mli b/src/ocaml-config/ocaml_config.mli index 7662ead4..31192d43 100644 --- a/src/ocaml-config/ocaml_config.mli +++ b/src/ocaml-config/ocaml_config.mli @@ -2,13 +2,13 @@ This library is internal to jbuilder and guarantees no API stability. *) -open Stdune +open! Stdune (** Represent a parsed and interpreted output of [ocamlc -config] and contents of [Makefile.config]. *) type t -val sexp_of_t : t -> Usexp.t +val to_sexp : t Sexp.To_sexp.t module Prog_and_args : sig type t = @@ -105,7 +105,8 @@ module Value : sig | Prog_and_args of Prog_and_args.t val to_string : t -> string - val sexp_of_t : t -> Usexp.t + + val to_sexp : t Sexp.To_sexp.t end val to_list : t -> (string * Value.t) list diff --git a/src/ocaml_flags.ml b/src/ocaml_flags.ml index 65399235..039c83ab 100644 --- a/src/ocaml_flags.ml +++ b/src/ocaml_flags.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Build.O @@ -87,7 +88,7 @@ let common t = t.common let dump t = Build.fanout3 t.common t.specific.byte t.specific.native >>^ fun (common, byte, native) -> - List.map ~f:Sexp.To_sexp.(pair string (list string)) + List.map ~f:Dsexp.To_sexp.(pair string (list string)) [ "flags" , common ; "ocamlc_flags" , byte ; "ocamlopt_flags" , native diff --git a/src/ocaml_flags.mli b/src/ocaml_flags.mli index fa9b1d4d..1a4da42b 100644 --- a/src/ocaml_flags.mli +++ b/src/ocaml_flags.mli @@ -1,6 +1,6 @@ (** OCaml flags *) -open Stdune +open! Stdune type t @@ -28,4 +28,4 @@ val prepend_common : string list -> t -> t val common : t -> (unit, string list) Build.t -val dump : t -> (unit, Sexp.t list) Build.t +val dump : t -> (unit, Dsexp.t list) Build.t diff --git a/src/ocamldep.ml b/src/ocamldep.ml index af61f85a..09bf7b44 100644 --- a/src/ocamldep.ml +++ b/src/ocamldep.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Build.O @@ -15,10 +16,10 @@ module Dep_graph = struct | Some x -> x | None -> Exn.code_error "Ocamldep.Dep_graph.deps_of" - [ "dir", Path.sexp_of_t t.dir - ; "modules", Sexp.To_sexp.(list Module.Name.t) + [ "dir", Path.to_sexp t.dir + ; "modules", Sexp.To_sexp.(list Module.Name.to_sexp) (Module.Name.Map.keys t.per_module) - ; "module", Module.Name.t m.name + ; "module", Module.Name.to_sexp m.name ] let top_closed t modules = diff --git a/src/odoc.ml b/src/odoc.ml index 78552f18..d9f3cff7 100644 --- a/src/odoc.ml +++ b/src/odoc.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Dune_file open Build.O diff --git a/src/odoc.mli b/src/odoc.mli index e8e1ee19..bc539c37 100644 --- a/src/odoc.mli +++ b/src/odoc.mli @@ -1,5 +1,6 @@ (** Odoc rules *) +open! Stdune open Import open Dune_file diff --git a/src/opam_file.ml b/src/opam_file.ml index e6022100..0dd04b4a 100644 --- a/src/opam_file.ml +++ b/src/opam_file.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open OpamParserTypes @@ -9,9 +10,9 @@ let load fn = OpamBaseParser.main OpamLexer.token lb (Path.to_string fn) with | OpamLexer.Error msg -> - Loc.fail_lex lb "%s" msg + Errors.fail_lex lb "%s" msg | Parsing.Parse_error -> - Loc.fail_lex lb "Parse error") + Errors.fail_lex lb "Parse error") let get_field t name = List.find_map t.file_contents diff --git a/src/opam_file.mli b/src/opam_file.mli index 9878cc5a..e64a5d68 100644 --- a/src/opam_file.mli +++ b/src/opam_file.mli @@ -1,6 +1,6 @@ (** Parsing and interpretation of opam files *) -open Stdune +open! Stdune open OpamParserTypes diff --git a/src/ordered_set_lang.ml b/src/ordered_set_lang.ml index 604a53a5..6cc5a209 100644 --- a/src/ordered_set_lang.ml +++ b/src/ordered_set_lang.ml @@ -1,3 +1,4 @@ +open! Stdune open! Import module Ast = struct @@ -19,7 +20,7 @@ end type 'ast generic = { ast : 'ast ; loc : Loc.t option - ; context : Univ_map.t (* Parsing context for Sexp.Of_sexp.parse *) + ; context : Univ_map.t (* Parsing context for Dsexp.Of_sexp.parse *) } type ast_expanded = (Loc.t * string, Ast.expanded) Ast.t @@ -34,7 +35,7 @@ module Parse = struct let open Stanza.Of_sexp in let rec one (kind : Stanza.File_kind.t) = peek_exn >>= function - | Atom (loc, A "\\") -> Loc.fail loc "unexpected \\" + | Atom (loc, A "\\") -> Errors.fail loc "unexpected \\" | (Atom (_, A "") | Quoted_string (_, _)) | Template _ -> elt | Atom (loc, A s) -> begin @@ -42,10 +43,10 @@ module Parse = struct | ":standard" -> junk >>> return Standard | ":include" -> - Loc.fail loc + Errors.fail loc "Invalid use of :include, should be: (:include )" | _ when s.[0] = ':' -> - Loc.fail loc "undefined symbol %s" s + Errors.fail loc "undefined symbol %s" s | _ -> elt end @@ -53,7 +54,7 @@ module Parse = struct match s, kind with | ":include", _ -> inc | s, Dune when s <> "" && s.[0] <> '-' && s.[0] <> ':' -> - Loc.fail loc + Errors.fail loc "This atom must be quoted because it is the first element \ of a list and doesn't start with - or :" | _ -> enter (many [] kind) @@ -77,7 +78,7 @@ module Parse = struct let with_include ~elt = generic ~elt ~inc:( sum [ ":include", - String_with_vars.t >>| fun s -> + String_with_vars.dparse >>| fun s -> Include s ]) @@ -85,11 +86,11 @@ module Parse = struct generic ~elt ~inc:( enter (loc >>= fun loc -> - Loc.fail loc "(:include ...) is not allowed here")) + Errors.fail loc "(:include ...) is not allowed here")) end -let t = +let dparse = let open Stanza.Of_sexp in let%map context = get_all and (loc, ast) = @@ -232,39 +233,39 @@ let standard = } let field ?(default=standard) ?check name = - let t = + let dparse = match check with - | None -> t - | Some x -> Sexp.Of_sexp.(>>>) x t + | None -> dparse + | Some x -> Dsexp.Of_sexp.(>>>) x dparse in - Sexp.Of_sexp.field name t ~default + Dsexp.Of_sexp.field name dparse ~default module Unexpanded = struct type ast = (String_with_vars.t, Ast.unexpanded) Ast.t type t = ast generic - let t : t Sexp.Of_sexp.t = + let dparse : t Dsexp.Of_sexp.t = let open Stanza.Of_sexp in let%map context = get_all and (loc, ast) = located ( Parse.with_include - ~elt:(String_with_vars.t >>| fun s -> Ast.Element s)) + ~elt:(String_with_vars.dparse >>| fun s -> Ast.Element s)) in { ast ; loc = Some loc ; context } - let sexp_of_t t = + let dgen t = let open Ast in - let rec loop : ast -> Sexp.t = function - | Element s -> String_with_vars.sexp_of_t s - | Standard -> Sexp.atom ":standard" + let rec loop = function + | Element s -> String_with_vars.dgen s + | Standard -> Dsexp.atom ":standard" | Union l -> List (List.map l ~f:loop) - | Diff (a, b) -> List [loop a; Sexp.unsafe_atom_of_string "\\"; loop b] + | Diff (a, b) -> List [loop a; Dsexp.unsafe_atom_of_string "\\"; loop b] | Include fn -> - List [ Sexp.unsafe_atom_of_string ":include" - ; String_with_vars.sexp_of_t fn + List [ Dsexp.unsafe_atom_of_string ":include" + ; String_with_vars.dgen fn ] in loop t.ast @@ -272,12 +273,12 @@ module Unexpanded = struct let standard = standard let field ?(default=standard) ?check name = - let t = + let dparse = match check with - | None -> t - | Some x -> Sexp.Of_sexp.(>>>) x t + | None -> dparse + | Some x -> Dsexp.Of_sexp.(>>>) x dparse in - Sexp.Of_sexp.field name t ~default + Dsexp.Of_sexp.field name dparse ~default let files t ~f = let rec loop acc (ast : ast) = @@ -349,7 +350,7 @@ module Unexpanded = struct match f fn with | [x] -> Value.to_path ~dir x | _ -> - Loc.fail (String_with_vars.loc fn) + Errors.fail (String_with_vars.loc fn) "An unquoted templated expanded to more than one value. \ A file path is expected in this position." in @@ -358,14 +359,14 @@ module Unexpanded = struct | None -> Exn.code_error "Ordered_set_lang.Unexpanded.expand" - [ "included-file", Path.sexp_of_t path - ; "files", Sexp.To_sexp.(list Path.sexp_of_t) + [ "included-file", Path.to_sexp path + ; "files", Sexp.To_sexp.(list Path.to_sexp) (Path.Map.keys files_contents) ] in let open Stanza.Of_sexp in parse - (Parse.without_include ~elt:(String_with_vars.t >>| f_elems)) + (Parse.without_include ~elt:(String_with_vars.dparse >>| f_elems)) context sexp | Union l -> Union (List.map l ~f:expand) diff --git a/src/ordered_set_lang.mli b/src/ordered_set_lang.mli index 336bb2fd..10037950 100644 --- a/src/ordered_set_lang.mli +++ b/src/ordered_set_lang.mli @@ -1,10 +1,11 @@ +open! Stdune (** [Ordered_set_lang.t] is a sexp-based representation for an ordered list of strings, with some set like operations. *) open Import type t -val t : t Sexp.Of_sexp.t +val dparse : t Dsexp.Of_sexp.t (** Return the location of the set. [loc standard] returns [None] *) val loc : t -> Loc.t option @@ -68,22 +69,22 @@ val is_standard : t -> bool val field : ?default:t - -> ?check:unit Sexp.Of_sexp.t + -> ?check:unit Dsexp.Of_sexp.t -> string - -> t Sexp.Of_sexp.fields_parser + -> t Dsexp.Of_sexp.fields_parser module Unexpanded : sig type expanded = t type t - include Sexp.Sexpable with type t := t + include Dsexp.Sexpable with type t := t val standard : t val field : ?default:t - -> ?check:unit Sexp.Of_sexp.t + -> ?check:unit Dsexp.Of_sexp.t -> string - -> t Sexp.Of_sexp.fields_parser + -> t Dsexp.Of_sexp.fields_parser val has_special_forms : t -> bool @@ -91,7 +92,7 @@ module Unexpanded : sig val files : t -> f:(String_with_vars.t -> Path.t) - -> Sexp.syntax * Path.Set.t + -> Dsexp.syntax * Path.Set.t (** Expand [t] using with the given file contents. [file_contents] is a map from filenames to their parsed contents. Every [(:include fn)] in [t] is replaced by @@ -99,7 +100,7 @@ module Unexpanded : sig val expand : t -> dir:Path.t - -> files_contents:Sexp.Ast.t Path.Map.t + -> files_contents:Dsexp.Ast.t Path.Map.t -> f:(String_with_vars.t -> Value.t list) -> expanded diff --git a/src/package.ml b/src/package.ml index af79aae1..6094d18d 100644 --- a/src/package.ml +++ b/src/package.ml @@ -1,4 +1,4 @@ -open Stdune +open! Stdune module Name = struct module T = Interned.Make(struct @@ -15,7 +15,7 @@ module Name = struct let pp fmt t = Format.pp_print_string fmt (to_string t) - let t = Sexp.Of_sexp.(map string ~f:of_string) + let dparse = Dsexp.Of_sexp.(map string ~f:of_string) module Infix = Comparable.Operators(T) end diff --git a/src/package.mli b/src/package.mli index 35ee0768..4859721c 100644 --- a/src/package.mli +++ b/src/package.mli @@ -1,6 +1,6 @@ (** Information about a package defined in the workspace *) -open Stdune +open! Stdune module Name : sig type t @@ -13,7 +13,7 @@ module Name : sig include Interned.S with type t := t - val t : t Sexp.Of_sexp.t + val dparse : t Dsexp.Of_sexp.t module Infix : Comparable.OPS with type t = t end diff --git a/src/path_dsexp.ml b/src/path_dsexp.ml new file mode 100644 index 00000000..8e650a01 --- /dev/null +++ b/src/path_dsexp.ml @@ -0,0 +1,38 @@ +open Stdune +open Path + +type t = Path.t + +let dgen p = + let arg = + match Internal.raw_kind p with + | Kind.External l -> External.to_string l + | Kind.Local l -> Local.to_string l + in + let make constr = + Dsexp.List [ Dsexp.atom constr + ; Dsexp.atom_or_quoted_string arg + ] + in + if is_in_build_dir p then + make "In_build_dir" + else if is_in_source_tree p then + make "In_source_tree" + else + make "External" + +let dparse = + let open Dsexp.Of_sexp in + let external_ = + plain_string (fun ~loc t -> + if Filename.is_relative t then + Dsexp.Of_sexp.of_sexp_errorf loc "Absolute path expected" + else + Path.of_string ~error_loc:loc t + ) + in + sum + [ "In_build_dir" , string >>| Path.(relative build_dir) + ; "In_source_tree", string >>| Path.(relative root) + ; "External" , external_ + ] diff --git a/src/path_dsexp.mli b/src/path_dsexp.mli new file mode 100644 index 00000000..bd491c69 --- /dev/null +++ b/src/path_dsexp.mli @@ -0,0 +1,3 @@ +open Stdune + +include Dsexp.Sexpable with type t = Path.t diff --git a/src/per_item.ml b/src/per_item.ml index e1929b75..59b35c9f 100644 --- a/src/per_item.ml +++ b/src/per_item.ml @@ -1,4 +1,4 @@ -open Import +open! Stdune module type S = sig type key diff --git a/src/per_item.mli b/src/per_item.mli index 41472fd5..3d0d4a04 100644 --- a/src/per_item.mli +++ b/src/per_item.mli @@ -5,7 +5,7 @@ value. *) -open Import +open! Stdune module type S = sig type key diff --git a/src/pform.ml b/src/pform.ml index 531f986b..aa2ddad6 100644 --- a/src/pform.ml +++ b/src/pform.ml @@ -1,3 +1,4 @@ +open! Stdune open Import module Var = struct diff --git a/src/pform.mli b/src/pform.mli index def55f81..78abad7a 100644 --- a/src/pform.mli +++ b/src/pform.mli @@ -1,4 +1,4 @@ -open Stdune +open! Stdune module Var : sig type t = diff --git a/src/preprocessing.ml b/src/preprocessing.ml index 81f2c7b0..ff20c1ea 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Build.O open Dune_file @@ -91,19 +92,19 @@ module Driver = struct resolve x >>= fun lib -> match get ~loc lib with | None -> - Error (Loc.exnf loc "%S is not a %s" name + Error (Errors.exnf loc "%S is not a %s" name (desc ~plural:false)) | Some t -> Ok t)) } - let to_sexp t = - let open Sexp.To_sexp in + let dgen t = + let open Dsexp.To_sexp in let f x = string (Lib.name (Lazy.force x.lib)) in ((1, 0), record - [ "flags" , Ordered_set_lang.Unexpanded.sexp_of_t + [ "flags" , Ordered_set_lang.Unexpanded.dgen t.info.flags - ; "lint_flags" , Ordered_set_lang.Unexpanded.sexp_of_t + ; "lint_flags" , Ordered_set_lang.Unexpanded.dgen t.info.lint_flags ; "main" , string t.info.main ; "replaces" , list f (Result.ok_exn t.replaces) @@ -119,9 +120,9 @@ module Driver = struct let make_error loc msg = match loc with - | User_file (loc, _) -> Error (Loc.exnf loc "%a" Fmt.text msg) + | User_file (loc, _) -> Error (Errors.exnf loc "%a" Fmt.text msg) | Dot_ppx (path, pps) -> - Error (Loc.exnf (Loc.in_file (Path.to_string path)) "%a" Fmt.text + Error (Errors.exnf (Loc.in_file (Path.to_string path)) "%a" Fmt.text (sprintf "Failed to create on-demand ppx rewriter for %s; %s" (String.enumerate_and (List.map pps ~f:Pp.to_string)) @@ -192,9 +193,9 @@ module Jbuild_driver = struct let parsing_context = Univ_map.singleton (Syntax.key Stanza.syntax) (0, 0) in - Sexp.parse_string ~mode:Single ~fname:"" info - ~lexer:Sexp.Lexer.jbuild_token - |> Sexp.Of_sexp.parse Driver.Info.parse parsing_context + Dsexp.parse_string ~mode:Single ~fname:"" info + ~lexer:Dsexp.Lexer.jbuild_token + |> Dsexp.Of_sexp.parse Driver.Info.parse parsing_context in (Pp.of_string name, { info @@ -436,7 +437,7 @@ let setup_reason_rules sctx (m : Module.t) = | ".re" -> ".re.ml" | ".rei" -> ".re.mli" | _ -> - Loc.fail + Errors.fail (Loc.in_file (Path.to_string (Path.drop_build_context_exn f.path))) "Unknown file extension for reason source file: %S" @@ -462,10 +463,7 @@ let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope ~dir_kind = let alias = Build_system.Alias.lint ~dir in let add_alias fn build = SC.add_alias_action sctx alias build - ~stamp:(List [ Sexp.unsafe_atom_of_string "lint" - ; Sexp.To_sexp.(option string) lib_name - ; Path.sexp_of_t fn - ]) + ~stamp:("lint", lib_name, fn) in let lint = Per_module.map lint ~f:(function @@ -490,7 +488,7 @@ let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope ~dir_kind = ~scope))) | Pps { loc; pps; flags; staged } -> if staged then - Loc.fail loc + Errors.fail loc "Staged ppx rewriters cannot be used as linters."; let args : _ Arg_spec.t = S [ As flags diff --git a/src/preprocessing.mli b/src/preprocessing.mli index 0fe05343..e58b5571 100644 --- a/src/preprocessing.mli +++ b/src/preprocessing.mli @@ -1,5 +1,6 @@ (** Preprocessing of OCaml source files *) +open! Stdune open! Import (** Preprocessing object *) diff --git a/src/print_diff.ml b/src/print_diff.ml index c25180de..e32ea735 100644 --- a/src/print_diff.ml +++ b/src/print_diff.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Fiber.O @@ -15,7 +16,7 @@ let print ?(skip_trailing_cr=Sys.win32) path1 path2 = in let loc = Loc.in_file file1 in let fallback () = - die "%aFiles %s and %s differ." Loc.print loc + die "%aFiles %s and %s differ." Errors.print loc (Path.to_string_maybe_quoted path1) (Path.to_string_maybe_quoted path2) in @@ -23,7 +24,7 @@ let print ?(skip_trailing_cr=Sys.win32) path1 path2 = match Bin.which "diff" with | None -> fallback () | Some prog -> - Format.eprintf "%a@?" Loc.print loc; + Format.eprintf "%a@?" Errors.print loc; Process.run ~dir ~env:Env.initial Strict prog (List.concat [ ["-u"] diff --git a/src/print_diff.mli b/src/print_diff.mli index 439c2e65..0df6c646 100644 --- a/src/print_diff.mli +++ b/src/print_diff.mli @@ -1,4 +1,4 @@ -open Stdune +open! Stdune (** Diff two files that are expected not to match. *) val print : ?skip_trailing_cr:bool -> Path.t -> Path.t -> _ Fiber.t diff --git a/src/process.ml b/src/process.ml index ba5c2cdd..d5af0c1a 100644 --- a/src/process.ml +++ b/src/process.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Fiber.O diff --git a/src/promotion.ml b/src/promotion.ml index 00c2255c..e1a75c97 100644 --- a/src/promotion.ml +++ b/src/promotion.ml @@ -1,4 +1,4 @@ -open Stdune +open! Stdune module File = struct type t = @@ -7,23 +7,12 @@ module File = struct } (* XXX these sexp converters will be useful for the dump command *) - let _t = - let open Sexp.Of_sexp in - peek_exn >>= function - | List (_, [_; Atom (_, A "as"); _]) -> - enter - (let%map src = Path.t - and () = junk - and dst = Path.t - in - { src; dst }) - | sexp -> - Sexp.Of_sexp.of_sexp_errorf (Sexp.Ast.loc sexp) - "( as ) expected" - - let _sexp_of_t { src; dst } = - Sexp.List [Path.sexp_of_t src; Sexp.unsafe_atom_of_string "as"; - Path.sexp_of_t dst] + let _to_sexp { src; dst } = + Sexp.List + [ Path.to_sexp src + ; Sexp.Atom "as" + ; Path.to_sexp dst + ] let db : t list ref = ref [] diff --git a/src/promotion.mli b/src/promotion.mli index 56ce9ad7..a307b1ab 100644 --- a/src/promotion.mli +++ b/src/promotion.mli @@ -1,4 +1,4 @@ -open Stdune +open! Stdune module File : sig type t = diff --git a/src/report_error.ml b/src/report_error.ml index 7832aa8d..f9ca92e6 100644 --- a/src/report_error.ml +++ b/src/report_error.ml @@ -1,3 +1,4 @@ +open! Stdune open Import let map_fname = ref (fun x -> x) @@ -44,7 +45,7 @@ let report_with_backtrace exn = in let pp ppf = Format.fprintf ppf "@{Error@}: %s\n" msg in { p with loc = Some loc; pp } - | Sexp.Of_sexp.Of_sexp (loc, msg, hint') -> + | Dsexp.Of_sexp.Of_sexp (loc, msg, hint') -> let loc = { loc with start = { loc.start with pos_fname = !map_fname loc.start.pos_fname } @@ -53,13 +54,13 @@ let report_with_backtrace exn = let pp ppf = Format.fprintf ppf "@{Error@}: %s%s\n" msg (match hint' with | None -> "" - | Some { Sexp.Of_sexp. on; candidates } -> + | Some { Dsexp.Of_sexp. on; candidates } -> hint on candidates) in { p with loc = Some loc; pp } - | Sexp.Parse_error e -> - let loc = Sexp.Parse_error.loc e in - let msg = Sexp.Parse_error.message e in + | Dsexp.Parse_error e -> + let loc = Dsexp.Parse_error.loc e in + let msg = Dsexp.Parse_error.message e in let map_pos (pos : Lexing.position) = { pos with pos_fname = !map_fname pos.pos_fname } in @@ -86,7 +87,7 @@ let report_with_backtrace exn = Format.fprintf ppf "@{Internal error, please report upstream \ including the contents of _build/log.@}\n\ Description:%a\n" - Usexp.pp_quoted sexp + Sexp.pp sexp } | Unix.Unix_error (err, func, fname) -> { p with pp = fun ppf -> @@ -120,7 +121,7 @@ let report exn = else p.loc in - Option.iter loc ~f:(fun loc -> Loc.print ppf loc); + Option.iter loc ~f:(fun loc -> Errors.print ppf loc); p.pp ppf; Format.pp_print_flush ppf (); let s = Buffer.contents err_buf in diff --git a/src/report_error.mli b/src/report_error.mli index a99fc34f..9838b3e9 100644 --- a/src/report_error.mli +++ b/src/report_error.mli @@ -1,3 +1,4 @@ +open! Stdune (** Error reporting *) (** Captures the backtrace and report an error. diff --git a/src/scheduler.ml b/src/scheduler.ml index 8d2ec4a4..d5e617dc 100644 --- a/src/scheduler.ml +++ b/src/scheduler.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Fiber.O @@ -195,7 +196,7 @@ let go ?(log=Log.no_log) ?(config=Config.default) ; waiting_for_available_job = Queue.create () } in - printer := print t; + Errors.printer := print t; let fiber = Fiber.Var.set t_var t (Fiber.with_error_handler (fun () -> fiber) ~on_error:Report_error.report) diff --git a/src/scheduler.mli b/src/scheduler.mli index 36e7c515..615e45ba 100644 --- a/src/scheduler.mli +++ b/src/scheduler.mli @@ -1,6 +1,6 @@ (** Scheduling *) -open Stdune +open! Stdune (** [go ?log ?config ?gen_status_line fiber] runs the following fiber until it terminates. [gen_status_line] is used to print a status line when [config.display = diff --git a/src/scope.ml b/src/scope.ml index 2eec9380..0b67d28a 100644 --- a/src/scope.ml +++ b/src/scope.ml @@ -1,3 +1,4 @@ +open! Stdune open Import type t = @@ -29,7 +30,7 @@ module DB = struct | None -> if Path.is_root d || not (Path.is_managed d) then Exn.code_error "Scope.DB.find_by_dir got an invalid path" - [ "dir" , Path.sexp_of_t dir + [ "dir" , Path.to_sexp dir ; "context", Sexp.To_sexp.string t.context ]; let scope = loop (Path.parent_exn d) in @@ -43,10 +44,10 @@ module DB = struct | Some x -> x | None -> Exn.code_error "Scope.DB.find_by_name" - [ "name" , Dune_project.Name.sexp_of_t name + [ "name" , Dune_project.Name.to_sexp name ; "context", Sexp.To_sexp.string t.context ; "names", - Sexp.To_sexp.(list Dune_project.Name.sexp_of_t) + Sexp.To_sexp.(list Dune_project.Name.to_sexp) (Project_name_map.keys t.by_name) ] @@ -59,7 +60,7 @@ module DB = struct | Ok x -> x | Error (_name, project1, project2) -> let to_sexp (project : Dune_project.t) = - Sexp.To_sexp.(pair Dune_project.Name.sexp_of_t Path.Local.sexp_of_t) + Sexp.To_sexp.(pair Dune_project.Name.to_sexp Path.Local.to_sexp) (Dune_project.name project, Dune_project.root project) in Exn.code_error "Scope.DB.create got two projects with the same name" diff --git a/src/scope.mli b/src/scope.mli index 20e5e8c4..0c0c0c7c 100644 --- a/src/scope.mli +++ b/src/scope.mli @@ -2,7 +2,7 @@ (** A scope is a project + a library database *) -open Stdune +open! Stdune type t diff --git a/src/simple_rules.ml b/src/simple_rules.ml index 7eda802f..d3faa2f4 100644 --- a/src/simple_rules.ml +++ b/src/simple_rules.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Dune_file open Build.O @@ -40,7 +41,7 @@ let copy_files sctx ~dir ~scope ~src_dir (def: Copy_files.t) = ensures that [sources_and_targets_known_so_far] returns the right answer for sub-directories only. *) if not (Path.is_descendant glob_in_src ~of_:src_dir) then - Loc.fail loc "%s is not a sub-directory of %s" + Errors.fail loc "%s is not a sub-directory of %s" (Path.to_string_maybe_quoted glob_in_src) (Path.to_string_maybe_quoted src_dir); let glob = Path.basename glob_in_src in let src_in_src = Path.parent_exn glob_in_src in @@ -49,11 +50,11 @@ let copy_files sctx ~dir ~scope ~src_dir (def: Copy_files.t) = | Ok re -> Re.compile re | Error (_pos, msg) -> - Loc.fail (String_with_vars.loc def.glob) "invalid glob: %s" msg + Errors.fail (String_with_vars.loc def.glob) "invalid glob: %s" msg in let file_tree = Super_context.file_tree sctx in if not (File_tree.dir_exists file_tree src_in_src) then - Loc.fail + Errors.fail loc "cannot find directory: %a" Path.pp src_in_src; @@ -89,13 +90,12 @@ let alias sctx ~dir ~scope (alias_conf : Alias_conf.t) = Blang.eval_bool blang ~dir ~f in let stamp = - let module S = Sexp.To_sexp in - Sexp.List - [ Sexp.unsafe_atom_of_string "user-alias" - ; Dune_file.Bindings.sexp_of_t Dune_file.Dep_conf.sexp_of_t alias_conf.deps - ; S.option Action.Unexpanded.sexp_of_t - (Option.map alias_conf.action ~f:snd) - ] + ( "user-alias" + , Dune_file.Bindings.map + ~f:Dune_file.Dep_conf.remove_locs alias_conf.deps + , Option.map ~f:(fun (_loc, a) -> Action.Unexpanded.remove_locs a) + alias_conf.action + ) in let loc = Some alias_conf.loc in if enabled then diff --git a/src/simple_rules.mli b/src/simple_rules.mli index fc8c5660..850fa01d 100644 --- a/src/simple_rules.mli +++ b/src/simple_rules.mli @@ -1,5 +1,6 @@ (** Simple rules: user, copy_files, alias *) +open! Stdune open Import open Dune_file diff --git a/src/stanza.ml b/src/stanza.ml index c59d2d6c..b650a102 100644 --- a/src/stanza.ml +++ b/src/stanza.ml @@ -1,9 +1,9 @@ -open Stdune +open! Stdune type t = .. module Parser = struct - type nonrec t = string * t list Sexp.Of_sexp.t + type nonrec t = string * t list Dsexp.Of_sexp.t end let syntax = @@ -13,7 +13,7 @@ let syntax = ] module File_kind = struct - type t = Sexp.syntax = Jbuild | Dune + type t = Dsexp.syntax = Jbuild | Dune let of_syntax = function | (0, _) -> Jbuild @@ -21,11 +21,11 @@ module File_kind = struct end let file_kind () = - let open Sexp.Of_sexp in + let open Dsexp.Of_sexp in Syntax.get_exn syntax >>| File_kind.of_syntax module Of_sexp = struct - include Sexp.Of_sexp + include Dsexp.Of_sexp exception Parens_no_longer_necessary of Loc.t @@ -88,7 +88,7 @@ module Of_sexp = struct match Univ_map.find parsing_context (Syntax.key syntax) with | Some (0, _) -> let last = Option.value_exn (List.last entries) in - Loc.warn (Sexp.Ast.loc last) + Errors.warn (Dsexp.Ast.loc last) "Field %S is present several times, previous occurrences are ignored." name | _ -> diff --git a/src/stanza.mli b/src/stanza.mli index f8b7249c..67d8ae86 100644 --- a/src/stanza.mli +++ b/src/stanza.mli @@ -1,6 +1,6 @@ (** Stanza in dune/jbuild files *) -open Stdune +open! Stdune type t = .. @@ -9,7 +9,7 @@ module Parser : sig Each stanza in a configuration file might produce several values of type [t], hence the [t list] here. *) - type nonrec t = string * t list Sexp.Of_sexp.t + type nonrec t = string * t list Dsexp.Of_sexp.t end (** Syntax identifier for the Dune language. [(0, X)] correspond to @@ -18,21 +18,21 @@ end val syntax : Syntax.t module File_kind : sig - type t = Sexp.syntax = Jbuild | Dune + type t = Dsexp.syntax = Jbuild | Dune val of_syntax : Syntax.Version.t -> t end (** Whether we are parsing a [jbuild] or [dune] file. *) -val file_kind : unit -> (File_kind.t, _) Sexp.Of_sexp.parser +val file_kind : unit -> (File_kind.t, _) Dsexp.Of_sexp.parser -(** Overlay for [Sexp.Of_sexp] where lists and records don't require +(** Overlay for [Dsexp.Of_sexp] where lists and records don't require an extra level of parentheses in Dune files. Additionally, [field_xxx] functions only warn about duplicated fields in jbuild files, for backward compatibility. *) module Of_sexp : sig - include module type of struct include Sexp.Of_sexp end + include module type of struct include Dsexp.Of_sexp end val record : 'a fields_parser -> 'a t val list : 'a t -> 'a list t diff --git a/src/stdune/bytes.ml b/src/stdune/bytes.ml new file mode 100644 index 00000000..c4d07798 --- /dev/null +++ b/src/stdune/bytes.ml @@ -0,0 +1,9 @@ +(* [blit_string] was forgotten from the labeled version in OCaml + 4.02—4.04. *) +include StdLabels.Bytes + +let blit_string ~src ~src_pos ~dst ~dst_pos ~len = + Caml.Bytes.blit_string src src_pos dst dst_pos len + +let sub_string dst ~pos ~len = + Caml.Bytes.sub_string dst pos len diff --git a/src/stdune/bytes.mli b/src/stdune/bytes.mli new file mode 100644 index 00000000..aa19112d --- /dev/null +++ b/src/stdune/bytes.mli @@ -0,0 +1,15 @@ +include module type of StdLabels.Bytes with type t = StdLabels.Bytes.t + +val blit_string + : src:string + -> src_pos:int + -> dst:t + -> dst_pos:int + -> len:int + -> unit + +val sub_string + : t + -> pos:int + -> len:int + -> string diff --git a/src/stdune/caml/caml.ml b/src/stdune/caml/caml.ml index a43c1037..6f04262a 100644 --- a/src/stdune/caml/caml.ml +++ b/src/stdune/caml/caml.ml @@ -1,9 +1,12 @@ (** This library is internal to jbuilder and guarantees no API stability. *) +module Bytes = Bytes module Filename = Filename module String = String module Char = Char module Result = Result +module Hashtbl = MoreLabels.Hashtbl +module Lexing = Lexing type ('a, 'error) result = ('a, 'error) Result.t = | Ok of 'a diff --git a/src/stdune/dune b/src/stdune/dune index d4857817..be117d05 100644 --- a/src/stdune/dune +++ b/src/stdune/dune @@ -2,4 +2,4 @@ (name stdune) (public_name dune._stdune) (synopsis "[Internal] Standard library of Dune") - (libraries caml unix usexp)) + (libraries caml unix)) diff --git a/src/stdune/escape.ml b/src/stdune/escape.ml new file mode 100644 index 00000000..830a9d88 --- /dev/null +++ b/src/stdune/escape.ml @@ -0,0 +1,74 @@ +module String = StringLabels + +type quote = + | Needs_quoting_with_length of int + | No_quoting + +let quote_length s = + let n = ref 0 in + let len = String.length s in + let needs_quoting = ref false in + for i = 0 to len - 1 do + n := !n + (match String.unsafe_get s i with + | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> + needs_quoting := true; + 2 + | ' ' -> + needs_quoting := true; + 1 + | '!' .. '~' -> 1 + | _ -> + needs_quoting := true; + 4) + done; + if !needs_quoting then + Needs_quoting_with_length len + else ( + assert (len = !n); + No_quoting + ) + +let escape_to s ~dst:s' ~ofs = + let n = ref ofs in + let len = String.length s in + for i = 0 to len - 1 do + begin match String.unsafe_get s i with + | ('\"' | '\\') as c -> + Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n c + | '\n' -> + Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'n' + | '\t' -> + Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 't' + | '\r' -> + Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'r' + | '\b' -> + Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'b' + | (' ' .. '~') as c -> Bytes.unsafe_set s' !n c + | c -> + let a = Char.code c in + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n (Char.unsafe_chr (48 + a / 100)); + incr n; + Bytes.unsafe_set s' !n (Char.unsafe_chr (48 + (a / 10) mod 10)); + incr n; + Bytes.unsafe_set s' !n (Char.unsafe_chr (48 + a mod 10)); + end; + incr n + done + +(* Surround [s] with quotes, escaping it if necessary. *) +let quote_if_needed s = + let len = String.length s in + match quote_length s with + | No_quoting -> + s + | Needs_quoting_with_length n -> + let s' = Bytes.create (n + 2) in + Bytes.unsafe_set s' 0 '"'; + if len = 0 || n > len then + escape_to s ~dst:s' ~ofs:1 + else + Bytes.blit_string ~src:s ~src_pos:0 ~dst:s' ~dst_pos:1 ~len; + Bytes.unsafe_set s' (n + 1) '"'; + Bytes.unsafe_to_string s' diff --git a/src/stdune/escape.mli b/src/stdune/escape.mli new file mode 100644 index 00000000..a9ccd90b --- /dev/null +++ b/src/stdune/escape.mli @@ -0,0 +1 @@ +val quote_if_needed : string -> string diff --git a/src/stdune/exn.ml b/src/stdune/exn.ml index bf2222db..ead3de51 100644 --- a/src/stdune/exn.ml +++ b/src/stdune/exn.ml @@ -1,10 +1,10 @@ type t = exn -exception Code_error of Usexp.t +exception Code_error of Sexp.t exception Fatal_error of string -exception Loc_error of Usexp.Loc.t * string +exception Loc_error of Loc.t * string external raise : exn -> _ = "%raise" external raise_notrace : exn -> _ = "%raise_notrace" @@ -26,9 +26,9 @@ let protect ~f ~finally = protectx () ~f ~finally let code_error message vars = Code_error - (Usexp.List (Usexp.atom_or_quoted_string message - :: List.map vars ~f:(fun (name, value) -> - Usexp.List [Usexp.atom_or_quoted_string name; value]))) + (List (Atom message + :: List.map vars ~f:(fun (name, value) -> + Sexp.List [Atom name; value]))) |> raise include diff --git a/src/stdune/exn.mli b/src/stdune/exn.mli index 29753a12..d7e3e2ab 100644 --- a/src/stdune/exn.mli +++ b/src/stdune/exn.mli @@ -2,7 +2,7 @@ (** An programming error, that should be reported upstream. The error message shouldn't try to be developer friendly rather than user friendly. *) -exception Code_error of Usexp.t +exception Code_error of Sexp.t (* CR-soon diml: @@ -14,14 +14,14 @@ exception Code_error of Usexp.t (** A fatal error, that should be reported to the user in a nice way *) exception Fatal_error of string -exception Loc_error of Usexp.Loc.t * string +exception Loc_error of Loc.t * string val fatalf - : ?loc:Usexp.Loc.t + : ?loc:Loc.t -> ('a, unit, string, string, string, 'b) format6 -> 'a -val code_error : string -> (string * Usexp.t) list -> _ +val code_error : string -> (string * Sexp.t) list -> _ type t = exn diff --git a/src/stdune/float.ml b/src/stdune/float.ml new file mode 100644 index 00000000..fb20079a --- /dev/null +++ b/src/stdune/float.ml @@ -0,0 +1,3 @@ +type t = float + +let to_string = string_of_float diff --git a/src/stdune/float.mli b/src/stdune/float.mli new file mode 100644 index 00000000..539e696c --- /dev/null +++ b/src/stdune/float.mli @@ -0,0 +1,3 @@ +type t = float + +val to_string : t -> string diff --git a/src/stdune/hashtbl.ml b/src/stdune/hashtbl.ml index 3e8c41e5..5383fee4 100644 --- a/src/stdune/hashtbl.ml +++ b/src/stdune/hashtbl.ml @@ -87,3 +87,14 @@ let fold t ~init ~f = foldi t ~init ~f:(fun _ x -> f x) let iter t ~f = iter ~f t let keys t = foldi t ~init:[] ~f:(fun key _ acc -> key :: acc) + +let to_sexp (type key) f g t = + let module M = + Map.Make(struct + type t = key + let compare a b = Ordering.of_int (compare a b) + end) + in + Map.to_sexp M.to_list f g + (foldi t ~init:M.empty ~f:(fun key data acc -> + M.add acc key data)) diff --git a/src/stdune/hashtbl.mli b/src/stdune/hashtbl.mli index e86e7b00..001492be 100644 --- a/src/stdune/hashtbl.mli +++ b/src/stdune/hashtbl.mli @@ -27,3 +27,5 @@ val foldi : ('a, 'b) t -> init:'c -> f:('a -> 'b -> 'c -> 'c) -> 'c val mem : ('a, _) t -> 'a -> bool val keys : ('a, _) t -> 'a list + +val to_sexp : ('a -> Sexp.t) -> ('b -> Sexp.t) -> ('a, 'b) t -> Sexp.t diff --git a/src/stdune/int.ml b/src/stdune/int.ml index a80839c6..2d496f46 100644 --- a/src/stdune/int.ml +++ b/src/stdune/int.ml @@ -7,6 +7,7 @@ module T = struct Eq else Gt + let to_sexp = Sexp.To_sexp.int end include T @@ -20,4 +21,6 @@ let of_string_exn s = failwith (Printf.sprintf "of_string_exn: invalid int %S" s) | s -> s +let to_string i = string_of_int i + module Infix = Comparable.Operators(T) diff --git a/src/stdune/int.mli b/src/stdune/int.mli index 4099bba3..4a001a01 100644 --- a/src/stdune/int.mli +++ b/src/stdune/int.mli @@ -1,9 +1,12 @@ type t = int val compare : t -> t -> Ordering.t +val to_sexp : t -> Sexp.t module Set : Set.S with type elt = t module Map : Map.S with type key = t val of_string_exn : string -> t +val to_string : t -> string + module Infix : Comparable.OPS with type t = t diff --git a/src/stdune/io.ml b/src/stdune/io.ml index 1a5bcb34..ac655ba3 100644 --- a/src/stdune/io.ml +++ b/src/stdune/io.ml @@ -107,11 +107,11 @@ let read_file_and_normalize_eols fn = else len - src_pos in - Bytes.blit_string src src_pos dst dst_pos len; - Bytes.sub_string dst 0 (dst_pos + len) + Bytes.blit_string ~src ~src_pos ~dst ~dst_pos ~len; + Bytes.sub_string dst ~pos:0 ~len:(dst_pos + len) | Some i -> let len = i - src_pos in - Bytes.blit_string src src_pos dst dst_pos len; + Bytes.blit_string ~src ~src_pos ~dst ~dst_pos ~len; let dst_pos = dst_pos + len in Bytes.set dst dst_pos '\n'; loop (i + 2) (dst_pos + 1) @@ -123,8 +123,3 @@ let compare_text_files fn1 fn2 = let s1 = read_file_and_normalize_eols fn1 in let s2 = read_file_and_normalize_eols fn2 in String.compare s1 s2 - -module Sexp = struct - let load ?lexer path ~mode = - with_lexbuf_from_file path ~f:(Usexp.Parser.parse ~mode ?lexer) -end diff --git a/src/stdune/io.mli b/src/stdune/io.mli index 31ca8143..9c767804 100644 --- a/src/stdune/io.mli +++ b/src/stdune/io.mli @@ -27,7 +27,3 @@ val copy_channels : in_channel -> out_channel -> unit val copy_file : ?chmod:(int -> int) -> src:Path.t -> dst:Path.t -> unit -> unit val read_all : in_channel -> string - -module Sexp : sig - val load : ?lexer:Usexp.Lexer.t -> Path.t -> mode:'a Sexp.Parser.Mode.t -> 'a -end diff --git a/src/stdune/loc.ml b/src/stdune/loc.ml new file mode 100644 index 00000000..a38a1e39 --- /dev/null +++ b/src/stdune/loc.ml @@ -0,0 +1,75 @@ +type t = + { start : Lexing.position + ; stop : Lexing.position + } + +let in_file fn = + let pos : Lexing.position = + { pos_fname = fn + ; pos_lnum = 1 + ; pos_cnum = 0 + ; pos_bol = 0 + } + in + { start = pos + ; stop = pos + } + +let none = in_file "" + +let of_lexbuf lexbuf : t = + { start = Lexing.lexeme_start_p lexbuf + ; stop = Lexing.lexeme_end_p lexbuf + } + +let sexp_of_position_no_file (p : Lexing.position) = + let open Sexp.To_sexp in + record + [ "pos_lnum", int p.pos_lnum + ; "pos_bol", int p.pos_bol + ; "pos_cnum", int p.pos_cnum + ] + +let to_sexp t = + let open Sexp.To_sexp in + record (* TODO handle when pos_fname differs *) + [ "pos_fname", string t.start.pos_fname + ; "start", sexp_of_position_no_file t.start + ; "stop", sexp_of_position_no_file t.stop + ] + +let equal_position + { Lexing.pos_fname = f_a; pos_lnum = l_a + ; pos_bol = b_a; pos_cnum = c_a } + { Lexing.pos_fname = f_b; pos_lnum = l_b + ; pos_bol = b_b; pos_cnum = c_b } + = + f_a = f_b + && l_a = l_b + && b_a = b_b + && c_a = c_b + +let equal + { start = start_a ; stop = stop_a } + { start = start_b ; stop = stop_b } + = + equal_position start_a start_b + && equal_position stop_a stop_b + +let of_pos (fname, lnum, cnum, enum) = + let pos : Lexing.position = + { pos_fname = fname + ; pos_lnum = lnum + ; pos_cnum = cnum + ; pos_bol = 0 + } + in + { start = pos + ; stop = { pos with pos_cnum = enum } + } + +let to_file_colon_line t = + Printf.sprintf "%s:%d" t.start.pos_fname t.start.pos_lnum + +let pp_file_colon_line ppf t = + Format.pp_print_string ppf (to_file_colon_line t) diff --git a/src/stdune/loc.mli b/src/stdune/loc.mli new file mode 100644 index 00000000..20d925fc --- /dev/null +++ b/src/stdune/loc.mli @@ -0,0 +1,22 @@ +type t = + { start : Lexing.position + ; stop : Lexing.position + } + +val in_file : string -> t + +val none : t + +val of_lexbuf : Lexing.lexbuf -> t + +val to_sexp : t -> Sexp.t + +val sexp_of_position_no_file : Lexing.position -> Sexp.t + +val equal : t -> t -> bool + +(** To be used with [__POS__] *) +val of_pos : (string * int * int * int) -> t + +val to_file_colon_line : t -> string +val pp_file_colon_line : Format.formatter -> t -> unit diff --git a/src/stdune/map.ml b/src/stdune/map.ml index e9e9e611..77ee8e18 100644 --- a/src/stdune/map.ml +++ b/src/stdune/map.ml @@ -143,3 +143,6 @@ module Make(Key : Comparable.S) : S with type key = Key.t = struct let superpose a b = union a b ~f:(fun _ _ y -> Some y) end + +let to_sexp to_list f g t = + Sexp.To_sexp.(list (pair f g)) (to_list t) diff --git a/src/stdune/map.mli b/src/stdune/map.mli index 5666e9ab..a887620d 100644 --- a/src/stdune/map.mli +++ b/src/stdune/map.mli @@ -1,3 +1,9 @@ module type S = Map_intf.S module Make(Key : Comparable.S) : S with type key = Key.t + +val to_sexp + : ('a -> ('b * 'c) list) + -> 'b Sexp.To_sexp.t + -> 'c Sexp.To_sexp.t + -> 'a Sexp.To_sexp.t diff --git a/src/stdune/path.ml b/src/stdune/path.ml index 3683a9b1..0b348525 100644 --- a/src/stdune/path.ml +++ b/src/stdune/path.ml @@ -34,10 +34,10 @@ let explode_path = module External : sig type t + val to_sexp : t Sexp.To_sexp.t + val compare : t -> t -> Ordering.t val compare_val : t -> t -> Ordering.t - val t : t Sexp.Of_sexp.t - val sexp_of_t : t Sexp.To_sexp.t val to_string : t -> string val of_string : string -> t val relative : t -> string -> t @@ -71,12 +71,7 @@ end = struct [ "t", Sexp.To_sexp.string t ]; make t - let sexp_of_t t = Sexp.To_sexp.string (to_string t) - let t = Sexp.Of_sexp.plain_string (fun ~loc t -> - if Filename.is_relative t then - Sexp.Of_sexp.of_sexp_errorf loc "Absolute path expected" - else - of_string t) + let to_sexp t = Sexp.To_sexp.string (to_string t) (* let rec cd_dot_dot t = @@ -130,16 +125,16 @@ end module Local : sig type t - val t : t Sexp.Of_sexp.t - val sexp_of_t : t Sexp.To_sexp.t + val to_sexp : t Sexp.To_sexp.t + val root : t val is_root : t -> bool val compare : t -> t -> Ordering.t val compare_val : t -> t -> Ordering.t val equal : t -> t -> bool - val of_string : ?error_loc:Usexp.Loc.t -> string -> t + val of_string : ?error_loc:Loc.t -> string -> t val to_string : t -> string - val relative : ?error_loc:Usexp.Loc.t -> t -> string -> t + val relative : ?error_loc:Loc.t -> t -> string -> t val append : t -> t -> t val parent : t -> t val mkdir_p : t -> unit @@ -218,13 +213,13 @@ end = struct | exception Not_found -> t | i -> String.sub t ~pos:(i + 1) ~len:(len - i - 1) - let sexp_of_t t = Sexp.To_sexp.string (to_string t) + let to_sexp t = Sexp.To_sexp.string (to_string t) let relative ?error_loc t path = if not (Filename.is_relative path) then ( Exn.code_error "Local.relative: received absolute path" - [ "t", sexp_of_t t - ; "path", Usexp.atom_or_quoted_string path + [ "t", to_sexp t + ; "path", Sexp.To_sexp.string path ] ); let rec loop t components = @@ -291,10 +286,6 @@ end = struct | _ -> relative root s ?error_loc - let t = - Sexp.Of_sexp.plain_string (fun ~loc:error_loc s -> - of_string s ~error_loc) - let rec mkdir_p t = if is_root t then () @@ -376,7 +367,7 @@ end = struct let make p = if is_root p then Exn.code_error "Path.Local.Prefix.make" - [ "path", sexp_of_t p ]; + [ "path", to_sexp p ]; let p = to_string p in { len = String.length p ; path = p @@ -407,8 +398,8 @@ let (abs_root, set_root) = | None -> root_dir := Some new_root | Some root_dir -> Exn.code_error "set_root: cannot set root_dir more than once" - [ "root_dir", External.sexp_of_t root_dir - ; "new_root_dir", External.sexp_of_t new_root + [ "root_dir", External.to_sexp root_dir + ; "new_root_dir", External.to_sexp new_root ] in let abs_root = lazy ( @@ -436,7 +427,7 @@ module Kind = struct | Local t -> Local.to_string t | External t -> External.to_string t - let sexp_of_t t = Sexp.atom_or_quoted_string (to_string t) + let to_sexp t = Sexp.To_sexp.string (to_string t) let of_string s = if Filename.is_relative s then @@ -487,8 +478,8 @@ let (build_dir_kind, build_dir_prefix, set_build_dir) = | External _ -> Local.Prefix.invalid) | Some build_dir -> Exn.code_error "set_build_dir: cannot set build_dir more than once" - [ "build_dir", Kind.sexp_of_t build_dir - ; "new_build_dir", Kind.sexp_of_t new_build_dir ] + [ "build_dir", Kind.to_sexp build_dir + ; "new_build_dir", Kind.to_sexp new_build_dir ] in let build_dir = lazy ( match !build_dir with @@ -607,25 +598,12 @@ let of_string ?error_loc s = else make_local_path (Local.of_string s ?error_loc) -let t = - let open Sexp.Of_sexp in - if_list - ~then_: - (sum - [ "In_build_dir" , Local.t >>| in_build_dir - ; "In_source_tree", Local.t >>| in_source_tree - ; "External" , External.t >>| external_ - ]) - ~else_: - (* necessary for old build dirs *) - (plain_string (fun ~loc:_ s -> of_string s)) - -let sexp_of_t t = +let to_sexp t = let constr f x y = Sexp.To_sexp.(pair string f) (x, y) in match t with - | In_build_dir s -> constr Local.sexp_of_t "In_build_dir" s - | In_source_tree s -> constr Local.sexp_of_t "In_source_tree" s - | External s -> constr External.sexp_of_t "External" s + | In_build_dir s -> constr Local.to_sexp "In_build_dir" s + | In_source_tree s -> constr Local.to_sexp "In_source_tree" s + | External s -> constr External.to_sexp "External" s let of_filename_relative_to_initial_cwd fn = external_ ( @@ -691,8 +669,8 @@ let append a b = | In_build_dir _ | External _ -> Exn.code_error "Path.append called with directory that's \ not in the source tree" - [ "a", sexp_of_t a - ; "b", sexp_of_t b + [ "a", to_sexp a + ; "b", to_sexp b ] | In_source_tree b -> append_local a b @@ -716,7 +694,7 @@ let parent_exn t = match parent t with | Some p -> p | None -> Exn.code_error "Path.parent:exn t is root" - ["t", sexp_of_t t] + ["t", to_sexp t] let is_strict_descendant_of_build_dir = function | In_build_dir p -> not (Local.is_root p) @@ -777,7 +755,7 @@ let drop_build_context t = let drop_build_context_exn t = match extract_build_context t with - | None -> Exn.code_error "Path.drop_build_context_exn" [ "t", sexp_of_t t ] + | None -> Exn.code_error "Path.drop_build_context_exn" [ "t", to_sexp t ] | Some (_, t) -> t let drop_optional_build_context t = @@ -819,7 +797,7 @@ let explode_exn t = match explode t with | Some s -> s | None -> Exn.code_error "Path.explode_exn" - ["path", sexp_of_t t] + ["path", to_sexp t] let exists t = try Sys.file_exists (to_string t) @@ -874,8 +852,8 @@ let insert_after_build_dir_exn = let error a b = Exn.code_error "Path.insert_after_build_dir_exn" - [ "path" , sexp_of_t a - ; "insert", Sexp.unsafe_atom_of_string b + [ "path" , to_sexp a + ; "insert", Sexp.To_sexp.string b ] in fun a b -> @@ -896,7 +874,7 @@ let rm_rf = fun t -> if not (is_managed t) then ( Exn.code_error "Path.rm_rf called on external dir" - ["t", sexp_of_t t] + ["t", to_sexp t] ); let fn = to_string t in match Unix.lstat fn with @@ -907,7 +885,7 @@ let mkdir_p = function | External s -> External.mkdir_p s | In_source_tree s -> Exn.code_error "Path.mkdir_p cannot dir in source" - ["s", Local.sexp_of_t s] + ["s", Local.to_sexp s] | In_build_dir k -> Kind.mkdir_p (Kind.append_local (Lazy.force build_dir_kind) k) @@ -949,7 +927,7 @@ let pp_debug ppf = function module Set = struct include Set.Make(T) - let sexp_of_t t = Sexp.To_sexp.(list sexp_of_t) (to_list t) + let to_sexp t = Sexp.To_sexp.(list to_sexp) (to_list t) let of_string_set ss ~f = String.Set.to_list ss |> List.map ~f @@ -959,3 +937,10 @@ end let in_source s = in_source_tree (Local.of_string s) module Table = Hashtbl.Make(T) + +module Internal = struct + let raw_kind = function + | In_build_dir l -> Kind.Local l + | In_source_tree l -> Local l + | External l -> External l +end diff --git a/src/stdune/path.mli b/src/stdune/path.mli index 4e2c1c0a..6880fa24 100644 --- a/src/stdune/path.mli +++ b/src/stdune/path.mli @@ -1,8 +1,9 @@ (** In the current workspace (anything under the current project root) *) module Local : sig type t - val sexp_of_t : t -> Sexp.t + val to_sexp : t -> Sexp.t val equal : t -> t -> bool + val to_string : t -> string end (** In the outside world *) @@ -26,8 +27,7 @@ end type t -val t : t Sexp.Of_sexp.t -val sexp_of_t : t Sexp.To_sexp.t +val to_sexp : t Sexp.To_sexp.t val compare : t -> t -> Ordering.t (** a directory is smaller than its descendants *) @@ -36,14 +36,14 @@ val equal : t -> t -> bool module Set : sig include Set.S with type elt = t - val sexp_of_t : t Sexp.To_sexp.t + val to_sexp : t Sexp.To_sexp.t val of_string_set : String.Set.t -> f:(string -> elt) -> t end module Map : Map.S with type key = t module Table : Hashtbl.S with type key = t -val of_string : ?error_loc:Usexp.Loc.t -> string -> t +val of_string : ?error_loc:Loc.t -> string -> t val to_string : t -> string (** [to_string_maybe_quoted t] is [maybe_quoted (to_string t)] *) @@ -56,7 +56,7 @@ val is_root : t -> bool val is_managed : t -> bool -val relative : ?error_loc:Usexp.Loc.t -> t -> string -> t +val relative : ?error_loc:Loc.t -> t -> string -> t (** Create an external path. If the argument is relative, assume it is relative to the initial directory jbuilder was launched in. *) @@ -164,3 +164,8 @@ val of_local : Local.t -> t (** Set the workspace root. Can onyl be called once and the path must be absolute *) val set_root : External.t -> unit + +(** Internal use only *) +module Internal : sig + val raw_kind : t -> Kind.t +end diff --git a/src/stdune/pp.ml b/src/stdune/pp.ml index c1bab2ab..8d4ebc16 100644 --- a/src/stdune/pp.ml +++ b/src/stdune/pp.ml @@ -59,8 +59,8 @@ module Renderer = struct assert (opening_len <= 0xffff); let buf = Bytes.create (2 + opening_len + closing_len) in set16 buf 0 opening_len; - Bytes.blit_string opening 0 buf 2 opening_len; - Bytes.blit_string closing 0 buf (2 + opening_len) closing_len; + Bytes.blit_string ~src:opening ~src_pos:0 ~dst:buf ~dst_pos:2 ~len:opening_len; + Bytes.blit_string ~src:closing ~src_pos:0 ~dst:buf ~dst_pos:(2 + opening_len) ~len:closing_len; Bytes.unsafe_to_string buf let extract_opening_tag s = diff --git a/src/stdune/set.ml b/src/stdune/set.ml index 4cc7b8d0..44a311ca 100644 --- a/src/stdune/set.ml +++ b/src/stdune/set.ml @@ -45,3 +45,6 @@ module Make(Elt : Comparable.S) : S with type elt = Elt.t = struct let choose = choose_opt let split x t = split t x end + +let to_sexp to_list f t = + Sexp.To_sexp.list f (to_list t) diff --git a/src/stdune/set.mli b/src/stdune/set.mli index 71f6c0fc..0ef23de6 100644 --- a/src/stdune/set.mli +++ b/src/stdune/set.mli @@ -1,3 +1,8 @@ module type S = Set_intf.S module Make(Elt : Comparable.S) : S with type elt = Elt.t + +val to_sexp + : ('a -> 'b list) + -> 'b Sexp.To_sexp.t + -> 'a Sexp.To_sexp.t diff --git a/src/stdune/sexp.ml b/src/stdune/sexp.ml index b3817f71..005e27fc 100644 --- a/src/stdune/sexp.ml +++ b/src/stdune/sexp.ml @@ -1,29 +1,23 @@ -include Usexp +module Array = ArrayLabels +module List = ListLabels +module String = StringLabels -module type Combinators = sig - type 'a t - val unit : unit t - val string : string t - val int : int t - val float : float t - val bool : bool t - val pair : 'a t -> 'b t -> ('a * 'b) t - val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t - val list : 'a t -> 'a list t - val array : 'a t -> 'a array t - val option : 'a t -> 'a option t - val string_set : String.Set.t t - val string_map : 'a t -> 'a String.Map.t t - val string_hashtbl : 'a t -> (string, 'a) Hashtbl.t t -end +type t = + | Atom of string + | List of t list + +(* XXX otherwise the dependency isn't recorded by bootstrap *) +module Sexp_intf = Sexp_intf module To_sexp = struct - type nonrec 'a t = 'a -> t + type sexp = t + type 'a t = 'a -> sexp + let unit () = List [] - let string = Usexp.atom_or_quoted_string - let int n = Atom (Atom.of_int n) - let float f = Atom (Atom.of_float f) - let bool b = Atom (Atom.of_bool b) + let string s = Atom s + let int i = Atom (string_of_int i) + let float f = Atom (string_of_float f) + let bool b = Atom (string_of_bool b) let pair fa fb (a, b) = List [fa a; fb b] let triple fa fb fc (a, b, c) = List [fa a; fb b; fc c] let list f l = List (List.map l ~f) @@ -31,596 +25,33 @@ module To_sexp = struct let option f = function | None -> List [] | Some x -> List [f x] - let string_set set = list atom (String.Set.to_list set) - let string_map f map = list (pair atom f) (String.Map.to_list map) + let record l = - List (List.map l ~f:(fun (n, v) -> List [Atom(Atom.of_string n); v])) - let string_hashtbl f h = - string_map f - (Hashtbl.foldi h ~init:String.Map.empty ~f:(fun key data acc -> - String.Map.add acc key data)) + List (List.map l ~f:(fun (n, v) -> List [Atom n; v])) - type field = string * Usexp.t option - - let field name f ?(equal=(=)) ?default v = - match default with - | None -> (name, Some (f v)) - | Some d -> - if equal d v then - (name, None) - else - (name, Some (f v)) - let field_o name f v = (name, Option.map ~f v) - - let record_fields (l : field list) = - List (List.filter_map l ~f:(fun (k, v) -> - Option.map v ~f:(fun v -> List[Atom (Atom.of_string k); v]))) - - let unknown _ = unsafe_atom_of_string "" + let unknown _ = Atom "" end -module Of_sexp = struct - type ast = Ast.t = - | Atom of Loc.t * Atom.t - | Quoted_string of Loc.t * string - | Template of Template.t - | List of Loc.t * ast list - - type hint = - { on: string - ; candidates: string list - } - - exception Of_sexp of Loc.t * string * hint option - - let of_sexp_error ?hint loc msg = - raise (Of_sexp (loc, msg, hint)) - let of_sexp_errorf ?hint loc fmt = - Printf.ksprintf (fun msg -> of_sexp_error loc ?hint msg) fmt - let no_templates ?hint loc fmt = - Printf.ksprintf (fun msg -> - of_sexp_error loc ?hint ("No variables allowed " ^ msg)) fmt - - type unparsed_field = - { values : Ast.t list - ; entry : Ast.t - ; prev : unparsed_field option (* Previous occurrence of this field *) - } - - module Name = struct - type t = string - let compare a b = - let alen = String.length a and blen = String.length b in - match Int.compare alen blen with - | Eq -> String.compare a b - | ne -> ne - end - - module Name_map = Map.Make(Name) - - type values = Ast.t list - type fields = - { unparsed : unparsed_field Name_map.t - ; known : string list - } - - (* Arguments are: - - - the location of the whole list - - the first atom when parsing a constructor or a field - - the universal map holding the user context - *) - type 'kind context = - | Values : Loc.t * string option * Univ_map.t -> values context - | Fields : Loc.t * string option * Univ_map.t -> fields context - - type ('a, 'kind) parser = 'kind context -> 'kind -> 'a * 'kind - - type 'a t = ('a, values) parser - type 'a fields_parser = ('a, fields) parser - - let return x _ctx state = (x, state) - let (>>=) t f ctx state = - let x, state = t ctx state in - f x ctx state - let (>>|) t f ctx state = - let x, state = t ctx state in - (f x, state) - let (>>>) a b ctx state = - let (), state = a ctx state in - b ctx state - let map t ~f = t >>| f - - let try_ t f ctx state = - try - t ctx state - with exn -> - f exn ctx state - - let get_user_context : type k. k context -> Univ_map.t = function - | Values (_, _, uc) -> uc - | Fields (_, _, uc) -> uc - - let get key ctx state = (Univ_map.find (get_user_context ctx) key, state) - let get_all ctx state = (get_user_context ctx, state) - - let set : type a b k. a Univ_map.Key.t -> a -> (b, k) parser -> (b, k) parser - = fun key v t ctx state -> - match ctx with - | Values (loc, cstr, uc) -> - t (Values (loc, cstr, Univ_map.add uc key v)) state - | Fields (loc, cstr, uc) -> - t (Fields (loc, cstr, Univ_map.add uc key v)) state - - let set_many : type a k. Univ_map.t -> (a, k) parser -> (a, k) parser - = fun map t ctx state -> - match ctx with - | Values (loc, cstr, uc) -> - t (Values (loc, cstr, Univ_map.superpose uc map)) state - | Fields (loc, cstr, uc) -> - t (Fields (loc, cstr, Univ_map.superpose uc map)) state - - let loc : type k. k context -> k -> Loc.t * k = fun ctx state -> - match ctx with - | Values (loc, _, _) -> (loc, state) - | Fields (loc, _, _) -> (loc, state) - - let at_eos : type k. k context -> k -> bool = fun ctx state -> - match ctx with - | Values _ -> state = [] - | Fields _ -> Name_map.is_empty state.unparsed - - let eos ctx state = (at_eos ctx state, state) - - let if_eos ~then_ ~else_ ctx state = - if at_eos ctx state then - then_ ctx state - else - else_ ctx state - - let repeat : 'a t -> 'a list t = - let rec loop t acc ctx l = - match l with - | [] -> (List.rev acc, []) - | _ -> - let x, l = t ctx l in - loop t (x :: acc) ctx l - in - fun t ctx state -> loop t [] ctx state - - let result : type a k. k context -> a * k -> a = - fun ctx (v, state) -> - match ctx with - | Values (_, cstr, _) -> begin - match state with - | [] -> v - | sexp :: _ -> - match cstr with - | None -> - of_sexp_errorf (Ast.loc sexp) "This value is unused" - | Some s -> - of_sexp_errorf (Ast.loc sexp) "Too many argument for %s" s - end - | Fields _ -> begin - match Name_map.choose state.unparsed with - | None -> v - | Some (name, { entry; _ }) -> - let name_loc = - match entry with - | List (_, s :: _) -> Ast.loc s - | _ -> assert false - in - of_sexp_errorf ~hint:{ on = name; candidates = state.known } - name_loc "Unknown field %s" name - end - - let parse t context sexp = - let ctx = Values (Ast.loc sexp, None, context) in - result ctx (t ctx [sexp]) - - let capture ctx state = - let f t = - result ctx (t ctx state) - in - (f, []) - - let end_of_list (Values (loc, cstr, _)) = - match cstr with - | None -> - let loc = { loc with start = loc.stop } in - of_sexp_errorf loc "Premature end of list" - | Some s -> - of_sexp_errorf loc "Not enough arguments for %s" s - [@@inline never] - - let next f ctx sexps = - match sexps with - | [] -> end_of_list ctx - | sexp :: sexps -> (f sexp, sexps) - [@@inline always] - - let next_with_user_context f ctx sexps = - match sexps with - | [] -> end_of_list ctx - | sexp :: sexps -> (f (get_user_context ctx) sexp, sexps) - [@@inline always] - - let peek _ctx sexps = - match sexps with - | [] -> (None, sexps) - | sexp :: _ -> (Some sexp, sexps) - [@@inline always] - - let peek_exn ctx sexps = - match sexps with - | [] -> end_of_list ctx - | sexp :: _ -> (sexp, sexps) - [@@inline always] - - let junk = next ignore - - let junk_everything : type k. (unit, k) parser = fun ctx state -> - match ctx with - | Values _ -> ((), []) - | Fields _ -> ((), { state with unparsed = Name_map.empty }) - - let keyword kwd = - next (function - | Atom (_, s) when Atom.to_string s = kwd -> () - | sexp -> of_sexp_errorf (Ast.loc sexp) "'%s' expected" kwd) - - let match_keyword l ~fallback = - peek >>= function - | Some (Atom (_, A s)) -> begin - match List.assoc l s with - | Some t -> junk >>> t - | None -> fallback - end - | _ -> fallback - - let until_keyword kwd ~before ~after = - let rec loop acc = - peek >>= function - | None -> return (List.rev acc, None) - | Some (Atom (_, A s)) when s = kwd -> - junk >>> after >>= fun x -> - return (List.rev acc, Some x) - | _ -> - before >>= fun x -> - loop (x :: acc) - in - loop [] - - let plain_string f = - next (function - | Atom (loc, A s) | Quoted_string (loc, s) -> f ~loc s - | Template { loc ; _ } | List (loc, _) -> - of_sexp_error loc "Atom or quoted string expected") - - let enter t = - next_with_user_context (fun uc sexp -> - match sexp with - | List (loc, l) -> - let ctx = Values (loc, None, uc) in - result ctx (t ctx l) - | sexp -> - of_sexp_error (Ast.loc sexp) "List expected") - - let if_list ~then_ ~else_ = - peek_exn >>= function - | List _ -> then_ - | _ -> else_ - - let if_paren_colon_form ~then_ ~else_ = - peek_exn >>= function - | List (_, Atom (loc, A s) :: _) when String.is_prefix s ~prefix:":" -> - let name = String.sub s ~pos:1 ~len:(String.length s - 1) in - enter - (junk >>= fun () -> - then_ >>| fun f -> - f (loc, name)) - | _ -> - else_ - - let fix f = - let rec p = lazy (f r) - and r ast = (Lazy.force p) ast in - r - - let loc_between_states : type k. k context -> k -> k -> Loc.t - = fun ctx state1 state2 -> - match ctx with - | Values _ -> begin - match state1 with - | sexp :: rest when rest == state2 -> (* common case *) - Ast.loc sexp - | [] -> - let (Values (loc, _, _)) = ctx in - { loc with start = loc.stop } - | sexp :: rest -> - let loc = Ast.loc sexp in - let rec search last l = - if l == state2 then - { loc with stop = (Ast.loc last).stop } - else - match l with - | [] -> - let (Values (loc, _, _)) = ctx in - { (Ast.loc sexp) with stop = loc.stop } - | sexp :: rest -> - search sexp rest - in - search sexp rest - end - | Fields _ -> - let parsed = - Name_map.merge state1.unparsed state2.unparsed - ~f:(fun _key before after -> - match before, after with - | Some _, None -> before - | _ -> None) - in - match - Name_map.values parsed - |> List.map ~f:(fun f -> Ast.loc f.entry) - |> List.sort ~compare:(fun a b -> - Int.compare a.Loc.start.pos_cnum b.start.pos_cnum) - with - | [] -> - let (Fields (loc, _, _)) = ctx in - loc - | first :: l -> - let last = List.fold_left l ~init:first ~f:(fun _ x -> x) in - { first with stop = last.stop } - - let located t ctx state1 = - let x, state2 = t ctx state1 in - ((loc_between_states ctx state1 state2, x), state2) - - let raw = next (fun x -> x) - - let unit = - next - (function - | List (_, []) -> () - | sexp -> of_sexp_error (Ast.loc sexp) "() expected") - - let basic desc f = - next (function - | Template { loc; _ } | List (loc, _) | Quoted_string (loc, _) -> - of_sexp_errorf loc "%s expected" desc - | Atom (loc, s) -> - match f (Atom.to_string s) with - | Result.Error () -> - of_sexp_errorf loc "%s expected" desc - | Ok x -> x) - - let string = plain_string (fun ~loc:_ x -> x) - let int = - basic "Integer" (fun s -> - match int_of_string s with - | x -> Ok x - | exception _ -> Result.Error ()) - - let float = - basic "Float" (fun s -> - match float_of_string s with - | x -> Ok x - | exception _ -> Result.Error ()) - - let pair a b = - enter - (a >>= fun a -> - b >>= fun b -> - return (a, b)) - - let triple a b c = - enter - (a >>= fun a -> - b >>= fun b -> - c >>= fun c -> - return (a, b, c)) - - let list t = enter (repeat t) - - let array t = list t >>| Array.of_list - - let option t = - enter - (eos >>= function - | true -> return None - | false -> t >>| Option.some) - - let string_set = list string >>| String.Set.of_list - let string_map t = - list (pair string t) >>= fun bindings -> - match String.Map.of_list bindings with - | Result.Ok x -> return x - | Error (key, _v1, _v2) -> - loc >>= fun loc -> - of_sexp_errorf loc "key %s present multiple times" key - - let string_hashtbl t = - string_map t >>| fun map -> - let tbl = Hashtbl.create (String.Map.cardinal map + 32) in - String.Map.iteri map ~f:(Hashtbl.add tbl); - tbl - - let find_cstr cstrs loc name ctx values = - match List.assoc cstrs name with - | Some t -> - result ctx (t ctx values) - | None -> - of_sexp_errorf loc - ~hint:{ on = name - ; candidates = List.map cstrs ~f:fst - } - "Unknown constructor %s" name - - let sum cstrs = - next_with_user_context (fun uc sexp -> - match sexp with - | Atom (loc, A s) -> - find_cstr cstrs loc s (Values (loc, Some s, uc)) [] - | Template { loc; _ } - | Quoted_string (loc, _) -> - of_sexp_error loc "Atom expected" - | List (loc, []) -> - of_sexp_error loc "Non-empty list expected" - | List (loc, name :: args) -> - match name with - | Quoted_string (loc, _) | List (loc, _) | Template { loc; _ } -> - of_sexp_error loc "Atom expected" - | Atom (s_loc, A s) -> - find_cstr cstrs s_loc s (Values (loc, Some s, uc)) args) - - let enum cstrs = - next (function - | Quoted_string (loc, _) - | Template { loc; _ } - | List (loc, _) -> of_sexp_error loc "Atom expected" - | Atom (loc, A s) -> - match List.assoc cstrs s with - | Some value -> value - | None -> - of_sexp_errorf loc - ~hint:{ on = s - ; candidates = List.map cstrs ~f:fst - } - "Unknown value %s" s) - - let bool = enum [ ("true", true); ("false", false) ] - - let consume name state = - { unparsed = Name_map.remove state.unparsed name - ; known = name :: state.known - } - - let add_known name state = - { state with known = name :: state.known } - - let map_validate t ~f ctx state1 = - let x, state2 = t ctx state1 in - match f x with - | Result.Ok x -> (x, state2) - | Error msg -> - let loc = loc_between_states ctx state1 state2 in - of_sexp_errorf loc "%s" msg - - let field_missing loc name = - of_sexp_errorf loc "field %s missing" name - [@@inline never] - - let field_present_too_many_times _ name entries = - match entries with - | _ :: second :: _ -> - of_sexp_errorf (Ast.loc second) "Field %S is present too many times" - name - | _ -> assert false - - let multiple_occurrences ?(on_dup=field_present_too_many_times) uc name last = - let rec collect acc x = - let acc = x.entry :: acc in - match x.prev with - | None -> acc - | Some prev -> collect acc prev - in - on_dup uc name (collect [] last) - [@@inline never] - - let find_single ?on_dup uc state name = - let res = Name_map.find state.unparsed name in - (match res with - | Some ({ prev = Some _; _ } as last) -> - multiple_occurrences uc name last ?on_dup - | _ -> ()); - res - - let field name ?default ?on_dup t (Fields (loc, _, uc)) state = - match find_single uc state name ?on_dup with - | Some { values; entry; _ } -> - let ctx = Values (Ast.loc entry, Some name, uc) in - let x = result ctx (t ctx values) in - (x, consume name state) - | None -> - match default with - | Some v -> (v, add_known name state) - | None -> field_missing loc name - - let field_o name ?on_dup t (Fields (_, _, uc)) state = - match find_single uc state name ?on_dup with - | Some { values; entry; _ } -> - let ctx = Values (Ast.loc entry, Some name, uc) in - let x = result ctx (t ctx values) in - (Some x, consume name state) - | None -> - (None, add_known name state) - - let field_b ?check ?on_dup name = - field name ~default:false ?on_dup - (Option.value check ~default:(return ()) >>= fun () -> - eos >>= function - | true -> return true - | _ -> bool) - - let multi_field name t (Fields (_, _, uc)) state = - let rec loop acc field = - match field with - | None -> acc - | Some { values; prev; entry } -> - let ctx = Values (Ast.loc entry, Some name, uc) in - let x = result ctx (t ctx values) in - loop (x :: acc) prev - in - let res = loop [] (Name_map.find state.unparsed name) in - (res, consume name state) - - let fields t (Values (loc, cstr, uc)) sexps = - let unparsed = - List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp -> - match sexp with - | List (_, name_sexp :: values) -> begin - match name_sexp with - | Atom (_, A name) -> - Name_map.add acc name - { values - ; entry = sexp - ; prev = Name_map.find acc name - } - | List (loc, _) | Quoted_string (loc, _) | Template { loc; _ } -> - of_sexp_error loc "Atom expected" - end - | _ -> - of_sexp_error (Ast.loc sexp) - "S-expression of the form ( ...) expected") - in - let ctx = Fields (loc, cstr, uc) in - let x = result ctx (t ctx { unparsed; known = [] }) in - (x, []) - - let record t = enter (fields t) - - type kind = - | Values of Loc.t * string option - | Fields of Loc.t * string option - - let kind : type k. k context -> k -> kind * k - = fun ctx state -> - match ctx with - | Values (loc, cstr, _) -> (Values (loc, cstr), state) - | Fields (loc, cstr, _) -> (Fields (loc, cstr), state) - - module Let_syntax = struct - let ( $ ) f t = - f >>= fun f -> - t >>| fun t -> - f t - let const = return - end -end - -module type Sexpable = sig - type t - val t : t Of_sexp.t - val sexp_of_t : t To_sexp.t -end +let rec to_string = function + | Atom s -> Escape.quote_if_needed s + | List l -> + Printf.sprintf "(%s)" + (List.map ~f:to_string l + |> String.concat ~sep:" ") + +let rec pp ppf = function + | Atom s -> + Format.pp_print_string ppf (Escape.quote_if_needed s) + | List [] -> + Format.pp_print_string ppf "()" + | List (first :: rest) -> + Format.pp_open_box ppf 1; + Format.pp_print_string ppf "("; + Format.pp_open_hvbox ppf 0; + pp ppf first; + List.iter rest ~f:(fun sexp -> + Format.pp_print_space ppf (); + pp ppf sexp); + Format.pp_close_box ppf (); + Format.pp_print_string ppf ")"; + Format.pp_close_box ppf () diff --git a/src/stdune/sexp.mli b/src/stdune/sexp.mli index 0d03211d..c299d18b 100644 --- a/src/stdune/sexp.mli +++ b/src/stdune/sexp.mli @@ -1,285 +1,16 @@ -include module type of struct include Usexp end with module Loc := Usexp.Loc - -module type Combinators = sig - type 'a t - val unit : unit t - - val string : string t - (** Convert an [Atom] or a [Quoted_string] from/to a string. *) - - val int : int t - val float : float t - val bool : bool t - val pair : 'a t -> 'b t -> ('a * 'b) t - val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t - val list : 'a t -> 'a list t - val array : 'a t -> 'a array t - val option : 'a t -> 'a option t - - val string_set : String.Set.t t - (** [atom_set] is a conversion to/from a set of strings representing atoms. *) - - val string_map : 'a t -> 'a String.Map.t t - (** [atom_map conv]: given a conversion [conv] to/from ['a], returns - a conversion to/from a map where the keys are atoms and the - values are of type ['a]. *) - - val string_hashtbl : 'a t -> (string, 'a) Hashtbl.t t - (** [atom_hashtbl conv] is similar to [atom_map] for hash tables. *) -end +type t = + | Atom of string + | List of t list module To_sexp : sig - type sexp = t - include Combinators with type 'a t = 'a -> t + type sexp + include Sexp_intf.Combinators with type 'a t = 'a -> t val record : (string * sexp) list -> sexp - type field - - val field - : string - -> 'a t - -> ?equal:('a -> 'a -> bool) - -> ?default:'a - -> 'a - -> field - val field_o : string -> 'a t-> 'a option -> field - - val record_fields : field list t - val unknown : _ t end with type sexp := t -module Loc = Usexp.Loc +val to_string : t -> string -module Of_sexp : sig - type ast = Ast.t = - | Atom of Loc.t * Atom.t - | Quoted_string of Loc.t * string - | Template of Template.t - | List of Loc.t * ast list - - type hint = - { on: string - ; candidates: string list - } - - exception Of_sexp of Loc.t * string * hint option - - (** Monad producing a value of type ['a] by parsing an input - composed of a sequence of S-expressions. - - The input can be seen either as a plain sequence of - S-expressions or a list of fields. The ['kind] parameter - indicates how the input is seen: - - - with {['kind = [values]]}, the input is seen as an ordered - sequence of S-expressions - - - with {['kind = [fields]]}, the input is seen as an unordered - sequence of fields - - A field is a S-expression of the form: [( ...)] - where [atom] is a plain atom, i.e. not a quoted string and not - containing variables. [values] is a sequence of zero, one or more - S-expressions. - - It is possible to switch between the two mode at any time using - the appropriate combinator. Some primitives can be used in both - mode while some are specific to one mode. *) - type ('a, 'kind) parser - - type values - type fields - - type 'a t = ('a, values) parser - type 'a fields_parser = ('a, fields) parser - - (** [parse parser context sexp] parse a S-expression using the - following parser. The input consist of a single - S-expression. [context] allows to pass extra information such as - versions to individual parsers. *) - val parse : 'a t -> Univ_map.t -> ast -> 'a - - val return : 'a -> ('a, _) parser - val (>>=) : ('a, 'k) parser -> ('a -> ('b, 'k) parser) -> ('b, 'k) parser - val (>>|) : ('a, 'k) parser -> ('a -> 'b) -> ('b, 'k) parser - val (>>>) : (unit, 'k) parser -> ('a, 'k) parser -> ('a, 'k) parser - val map : ('a, 'k) parser -> f:('a -> 'b) -> ('b, 'k) parser - val try_ : ('a, 'k) parser -> (exn -> ('a, 'k) parser) -> ('a, 'k) parser - - (** Access to the context *) - val get : 'a Univ_map.Key.t -> ('a option, _) parser - val set : 'a Univ_map.Key.t -> 'a -> ('b, 'k) parser -> ('b, 'k) parser - val get_all : (Univ_map.t, _) parser - val set_many : Univ_map.t -> ('a, 'k) parser -> ('a, 'k) parser - - (** Return the location of the list currently being parsed. *) - val loc : (Loc.t, _) parser - - (** End of sequence condition. Uses [then_] if there are no more - S-expressions to parse, [else_] otherwise. *) - val if_eos : then_:('a, 'b) parser -> else_:('a, 'b) parser -> ('a, 'b) parser - - (** If the next element of the sequence is a list, parse it with - [then_], otherwise parse it with [else_]. *) - val if_list - : then_:'a t - -> else_:'a t - -> 'a t - - (** If the next element of the sequence is of the form [(: - ...)], use [then_] to parse [...]. Otherwise use [else_]. *) - val if_paren_colon_form - : then_:(Loc.t * string -> 'a) t - -> else_:'a t - -> 'a t - - (** Expect the next element to be the following atom. *) - val keyword : string -> unit t - - (** {[match_keyword [(k1, t1); (k2, t2); ...] ~fallback]} inspects - the next element of the input sequence. If it is an atom equal to - one of [k1], [k2], ... then the corresponding parser is used to - parse the rest of the sequence. Other [fallback] is used. *) - val match_keyword - : (string * 'a t) list - -> fallback:'a t - -> 'a t - - (** Use [before] to parse elements until the keyword is - reached. Then use [after] to parse the rest. *) - val until_keyword - : string - -> before:'a t - -> after:'b t - -> ('a list * 'b option) t - - (** What is currently being parsed. The second argument is the atom - at the beginnig of the list when inside a [sum ...] or [field - ...]. *) - type kind = - | Values of Loc.t * string option - | Fields of Loc.t * string option - val kind : (kind, _) parser - - (** [repeat t] use [t] to consume all remaning elements of the input - until the end of sequence is reached. *) - val repeat : 'a t -> 'a list t - - (** Capture the rest of the input for later parsing *) - val capture : ('a t -> 'a) t - - (** [enter t] expect the next element of the input to be a list and - parse its contents with [t]. *) - val enter : 'a t -> 'a t - - (** [fields fp] converts the rest of the current input to a list of - fields and parse them with [fp]. This operation fails if one the - S-expression in the input is not of the form [( - ...)] *) - val fields : 'a fields_parser -> 'a t - - (** [record fp = enter (fields fp)] *) - val record : 'a fields_parser -> 'a t - - (** Consume the next element of the input as a string, int, char, ... *) - include Combinators with type 'a t := 'a t - - (** Unparsed next element of the input *) - val raw : ast t - - (** Inspect the next element of the input without consuming it *) - val peek : ast option t - - (** Same as [peek] but fail if the end of input is reached *) - val peek_exn : ast t - - (** Consume and ignore the next element of the input *) - val junk : unit t - - (** Ignore all the rest of the input *) - val junk_everything : (unit, _) parser - - (** [plain_string f] expects the next element of the input to be a - plain string, i.e. either an atom or a quoted string, but not a - template nor a list. *) - val plain_string : (loc:Loc.t -> string -> 'a) -> 'a t - - val fix : ('a t -> 'a t) -> 'a t - - val of_sexp_error - : ?hint:hint - -> Loc.t - -> string - -> _ - val of_sexp_errorf - : ?hint:hint - -> Loc.t - -> ('a, unit, string, 'b) format4 - -> 'a - - val no_templates - : ?hint:hint - -> Loc.t - -> ('a, unit, string, 'b) format4 - -> 'a - - val located : ('a, 'k) parser -> (Loc.t * 'a, 'k) parser - - val enum : (string * 'a) list -> 'a t - - (** Parser that parse a S-expression of the form [( - ...)] or []. [] is looked up in the list and - the remaining s-expressions are parsed using the corresponding - list parser. *) - val sum : (string * 'a t) list -> 'a t - - (** Check the result of a list parser, and raise a properly located - error in case of failure. *) - val map_validate - : 'a fields_parser - -> f:('a -> ('b, string) Result.t) - -> 'b fields_parser - - (** {3 Parsing record fields} *) - - val field - : string - -> ?default:'a - -> ?on_dup:(Univ_map.t -> string -> Ast.t list -> unit) - -> 'a t - -> 'a fields_parser - val field_o - : string - -> ?on_dup:(Univ_map.t -> string -> Ast.t list -> unit) - -> 'a t - -> 'a option fields_parser - - val field_b - : ?check:(unit t) - -> ?on_dup:(Univ_map.t -> string -> Ast.t list -> unit) - -> string - -> bool fields_parser - - (** A field that can appear multiple times *) - val multi_field - : string - -> 'a t - -> 'a list fields_parser - - (** Default value for [on_dup]. It fails with an appropriate error - message. *) - val field_present_too_many_times : Univ_map.t -> string -> Ast.t list -> _ - - module Let_syntax : sig - val ( $ ) : ('a -> 'b, 'k) parser -> ('a, 'k) parser -> ('b, 'k) parser - val const : 'a -> ('a, _) parser - end -end - -module type Sexpable = sig - type t - val t : t Of_sexp.t - val sexp_of_t : t To_sexp.t -end +val pp : Format.formatter -> t -> unit diff --git a/src/stdune/sexp_intf.ml b/src/stdune/sexp_intf.ml new file mode 100644 index 00000000..8954d017 --- /dev/null +++ b/src/stdune/sexp_intf.ml @@ -0,0 +1,13 @@ +module type Combinators = sig + type 'a t + val unit : unit t + val string : string t + val int : int t + val float : float t + val bool : bool t + val pair : 'a t -> 'b t -> ('a * 'b) t + val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t + val list : 'a t -> 'a list t + val array : 'a t -> 'a array t + val option : 'a t -> 'a option t +end diff --git a/src/stdune/stdune.ml b/src/stdune/stdune.ml index bf38fdb9..c0ce1286 100644 --- a/src/stdune/stdune.ml +++ b/src/stdune/stdune.ml @@ -1,5 +1,6 @@ module Ansi_color = Ansi_color module Array = Array +module Bytes = Bytes module Comparable = Comparable module Either = Either module Exn = Exn @@ -19,11 +20,13 @@ module Staged = Staged module String = String module Char = Char module Bool = Bool +module Sexp_intf = Sexp_intf module Sexp = Sexp module Path = Path module Fmt = Fmt module Interned = Interned module Univ_map = Univ_map +module Loc = Loc external reraise : exn -> _ = "%reraise" @@ -44,3 +47,5 @@ type ordering = Ordering.t = | Lt | Eq | Gt + +let sprintf = Printf.sprintf diff --git a/src/stdune/string.ml b/src/stdune/string.ml index 00c926e0..5816ff03 100644 --- a/src/stdune/string.ml +++ b/src/stdune/string.ml @@ -203,6 +203,7 @@ let maybe_quoted s = Printf.sprintf {|"%s"|} escaped module Set = Set.Make(T) + module Map = struct include Map.Make(T) let pp f fmt t = diff --git a/src/stdune/string.mli b/src/stdune/string.mli index 3a0844b1..6ba31660 100644 --- a/src/stdune/string.mli +++ b/src/stdune/string.mli @@ -1,4 +1,5 @@ -include module type of struct include StringLabels end +type t = string +include module type of struct include StringLabels end with type t := t val equal : t -> t -> bool val compare : t -> t -> Ordering.t diff --git a/src/stdune/univ_map.ml b/src/stdune/univ_map.ml index fc545b7a..95bdaea0 100644 --- a/src/stdune/univ_map.ml +++ b/src/stdune/univ_map.ml @@ -14,21 +14,21 @@ module Key = struct type 'a Witness.t += T : t Witness.t val id : int val name : string - val sexp_of_t : t -> Usexp.t + val to_sexp : t -> Sexp.t end type 'a t = (module T with type t = 'a) let next = ref 0 - let create (type a) ~name sexp_of_t = + let create (type a) ~name to_sexp = let n = !next in next := n + 1; let module M = struct type t = a type 'a Witness.t += T : t Witness.t let id = n - let sexp_of_t = sexp_of_t + let to_sexp = to_sexp let name = name end in (module M : T with type t = a) @@ -79,13 +79,13 @@ let singleton key v = Int.Map.singleton (Key.id key) (Binding.T (key, v)) let superpose = Int.Map.superpose -let sexp_of_t (t : t) = - let open Usexp in +let to_sexp (t : t) = + let open Sexp in List ( Int.Map.to_list t |> List.map ~f:(fun (_, (Binding.T (key, v))) -> let (module K) = key in List - [ atom_or_quoted_string K.name - ; K.sexp_of_t v + [ Atom K.name + ; K.to_sexp v ])) diff --git a/src/stdune/univ_map.mli b/src/stdune/univ_map.mli index 3e764dbb..d83bd1bf 100644 --- a/src/stdune/univ_map.mli +++ b/src/stdune/univ_map.mli @@ -7,7 +7,7 @@ type t module Key : sig type 'a t - val create : name:string -> ('a -> Usexp.t) -> 'a t + val create : name:string -> ('a -> Sexp.t) -> 'a t end val empty : t @@ -23,4 +23,4 @@ val singleton : 'a Key.t -> 'a -> t in [b]. *) val superpose : t -> t -> t -val sexp_of_t : t -> Usexp.t +val to_sexp : t -> Sexp.t diff --git a/src/string_with_vars.ml b/src/string_with_vars.ml index f41d580f..b7864055 100644 --- a/src/string_with_vars.ml +++ b/src/string_with_vars.ml @@ -1,9 +1,10 @@ +open! Stdune open! Import -open Usexp.Template +open Dsexp.Template type t = - { template : Usexp.Template.t + { template : Dsexp.Template.t ; syntax_version : Syntax.Version.t } @@ -25,7 +26,7 @@ let literal ~quoted ~loc s = (* This module implements the "old" template parsing that is only used in jbuild files *) module Jbuild : sig - val parse : string -> loc:Loc.t -> quoted:bool -> Usexp.Template.t + val parse : string -> loc:Loc.t -> quoted:bool -> Dsexp.Template.t end = struct type var_syntax = Parens | Braces module Token = struct @@ -94,24 +95,24 @@ end = struct } end -let t = - let open Sexp.Of_sexp in +let dparse = + let open Dsexp.Of_sexp in let jbuild = raw >>| function | Template _ as t -> Exn.code_error "Unexpected dune template from a jbuild file" - [ "t", Usexp.Ast.remove_locs t + [ "t", Dsexp.to_sexp (Dsexp.Ast.remove_locs t) ] | Atom(loc, A s) -> Jbuild.parse s ~loc ~quoted:false | Quoted_string (loc, s) -> Jbuild.parse s ~loc ~quoted:true - | List (loc, _) -> Sexp.Of_sexp.of_sexp_error loc "Atom expected" + | List (loc, _) -> Dsexp.Of_sexp.of_sexp_error loc "Atom expected" in let dune = raw >>| function | Template t -> t | Atom(loc, A s) -> literal ~quoted:false ~loc s | Quoted_string (loc, s) -> literal ~quoted:true ~loc s - | List (loc, _) -> Sexp.Of_sexp.of_sexp_error loc "Unexpected list" + | List (loc, _) -> Dsexp.Of_sexp.of_sexp_error loc "Unexpected list" in let template_parser = Stanza.Of_sexp.switch_file_kind ~jbuild ~dune in let%map syntax_version = Syntax.get_exn Stanza.syntax @@ -182,9 +183,9 @@ module Partial = struct end let invalid_multivalue (v : var) x = - Loc.fail v.loc "Variable %s expands to %d values, \ - however a single value is expected here. \ - Please quote this atom." + Errors.fail v.loc "Variable %s expands to %d values, \ + however a single value is expected here. \ + Please quote this atom." (string_of_var v) (List.length x) module Var = struct @@ -203,7 +204,7 @@ module Var = struct let to_string = string_of_var - let sexp_of_t t = Sexp.atom (to_string t) + let to_sexp t = Sexp.To_sexp.string (to_string t) let with_name t ~name = { t with name } @@ -271,9 +272,9 @@ let expand t ~mode ~dir ~f = begin match var.syntax with | Percent -> if Var.is_macro var then - Loc.fail var.loc "Unknown macro %s" (Var.describe var) + Errors.fail var.loc "Unknown macro %s" (Var.describe var) else - Loc.fail var.loc "Unknown variable %S" (Var.name var) + Errors.fail var.loc "Unknown variable %S" (Var.name var) | Dollar_brace | Dollar_paren -> Some [Value.String (string_of_var var)] end @@ -284,7 +285,9 @@ let expand t ~mode ~dir ~f = let partial_expand t ~mode ~dir ~f = partial_expand t ~mode ~dir ~f -let sexp_of_t t = Usexp.Template t.template +let dgen { template; syntax_version = _ } = Dsexp.Template template + +let to_sexp t = Dsexp.to_sexp (dgen t) let is_var { template; syntax_version = _ } ~name = match template.parts with @@ -295,3 +298,7 @@ let text_only t = match t.template.parts with | [Text s] -> Some s | _ -> None + +let remove_locs t = + { t with template = Dsexp.Template.remove_locs t.template + } diff --git a/src/string_with_vars.mli b/src/string_with_vars.mli index 4a3736bd..5efce2a1 100644 --- a/src/string_with_vars.mli +++ b/src/string_with_vars.mli @@ -1,3 +1,4 @@ +open! Stdune (** String with variables of the form ${...} or $(...) Variables cannot contain "${", "$(", ")" or "}". For instance in "$(cat @@ -8,17 +9,14 @@ open Import type t (** A sequence of text and variables. *) -val t : t Sexp.Of_sexp.t -(** [t ast] takes an [ast] sexp and returns a string-with-vars. This - function distinguishes between unquoted variables — such as ${@} — - and quoted variables — such as "${@}". *) - val loc : t -> Loc.t (** [loc t] returns the location of [t] — typically, in the jbuild file. *) val syntax_version : t -> Syntax.Version.t -val sexp_of_t : t -> Sexp.t +val to_sexp : t Sexp.To_sexp.t + +include Dsexp.Sexpable with type t := t (** [t] generated by the OCaml code. The first argument should be [__POS__]. The second is either a string to parse, a variable name @@ -49,7 +47,7 @@ end module Var : sig type t - val sexp_of_t : t -> Sexp.t + val to_sexp : t -> Sexp.t val name : t -> string val loc : t -> Loc.t @@ -79,3 +77,5 @@ val partial_expand -> dir:Path.t -> f:(Value.t list option expander) -> 'a Partial.t + +val remove_locs : t -> t diff --git a/src/sub_system.ml b/src/sub_system.ml index e738a7e3..75e0559a 100644 --- a/src/sub_system.ml +++ b/src/sub_system.ml @@ -1,3 +1,4 @@ +open! Stdune open! Import include Sub_system_intf @@ -7,7 +8,7 @@ module Register_backend(M : Backend) = struct include Lib.Sub_system.Register(struct include M type Lib.Sub_system.t += T of t - let to_sexp = Some to_sexp + let dgen = Some dgen end) let top_closure l ~deps = @@ -39,7 +40,7 @@ module Register_backend(M : Backend) = struct Lib.DB.resolve db (loc, name) >>= fun lib -> match get lib with | None -> - Error (Loc.exnf loc "%S is not %s %s" name M.desc_article + Error (Errors.exnf loc "%S is not %s %s" name M.desc_article (M.desc ~plural:false)) | Some t -> Ok t @@ -52,7 +53,7 @@ module Register_backend(M : Backend) = struct let to_exn t ~loc = match t with | Too_many_backends backends -> - Loc.exnf loc + Errors.exnf loc "Too many independent %s found:\n%s" (M.desc ~plural:true) (String.concat ~sep:"\n" @@ -62,7 +63,7 @@ module Register_backend(M : Backend) = struct (Lib.name lib) (Path.to_string_maybe_quoted (Lib.src_dir lib))))) | No_backend_found -> - Loc.exnf loc "No %s found." (M.desc ~plural:false) + Errors.exnf loc "No %s found." (M.desc ~plural:false) | Other exn -> exn @@ -160,7 +161,7 @@ module Register_end_point(M : End_point) = struct type t = Library_compilation_context.t -> unit type Lib.Sub_system.t += T = Gen let instantiate ~resolve:_ ~get:_ _id info = gen info - let to_sexp = None + let dgen = None end) end diff --git a/src/sub_system_intf.ml b/src/sub_system_intf.ml index 18461df9..428e6ef7 100644 --- a/src/sub_system_intf.ml +++ b/src/sub_system_intf.ml @@ -1,3 +1,4 @@ +open! Stdune open! Import module type Info = Dune_file.Sub_system_info.S @@ -34,7 +35,7 @@ module type Backend = sig (** Dump the sub-system configuration. This is used to generate META files. *) - val to_sexp : t -> Syntax.Version.t * Sexp.t + val dgen : t -> Syntax.Version.t * Dsexp.t end module type Registered_backend = sig diff --git a/src/sub_system_name.ml b/src/sub_system_name.ml index bcd2411a..3a82be33 100644 --- a/src/sub_system_name.ml +++ b/src/sub_system_name.ml @@ -1,4 +1,4 @@ -open Stdune +open! Stdune include Interned.Make(struct let initial_size = 16 diff --git a/src/super_context.ml b/src/super_context.ml index 72e84a7b..8311c97c 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Dune_file @@ -130,7 +131,7 @@ let expand_ocaml_config t pform name = match String.Map.find t.ocaml_config name with | Some x -> x | None -> - Loc.fail (String_with_vars.Var.loc pform) + Errors.fail (String_with_vars.Var.loc pform) "Unknown ocaml configuration variable %S" name @@ -144,7 +145,7 @@ let expand_vars t ~mode ~scope ~dir ?(bindings=Pform.Map.empty) s = | Macro (Ocaml_config, s) -> expand_ocaml_config t pform s | Var Project_root -> [Value.Dir (Scope.root scope)] | _ -> - Loc.fail (String_with_vars.Var.loc pform) + Errors.fail (String_with_vars.Var.loc pform) "%s isn't allowed in this position" (String_with_vars.Var.describe pform))) @@ -166,7 +167,7 @@ module Pkg_version = struct module V = Vfile_kind.Make(struct type t = string option - let t = Sexp.To_sexp.(option string) + let dgen = Dsexp.To_sexp.(option string) let name = "Pkg_version" end) @@ -259,7 +260,7 @@ end = struct let parse_lib_file ~loc s = match String.lsplit2 s ~on:':' with | None -> - Loc.fail loc "invalid %%{lib:...} form: %s" s + Errors.fail loc "invalid %%{lib:...} form: %s" s | Some x -> x open Build.O @@ -278,10 +279,10 @@ end = struct | Var Targets -> begin match targets_written_by_user with | Infer -> - Loc.fail loc "You cannot use %s with inferred rules." + Errors.fail loc "You cannot use %s with inferred rules." (String_with_vars.Var.describe pform) | Alias -> - Loc.fail loc "You cannot use %s in aliases." + Errors.fail loc "You cannot use %s in aliases." (String_with_vars.Var.describe pform) | Static l -> Some (Value.L.dirs l) (* XXX hack to signal no dep *) @@ -347,7 +348,7 @@ end = struct Resolved_forms.add_ddep acc ~key x | None -> Resolved_forms.add_fail acc { fail = fun () -> - Loc.fail loc + Errors.fail loc "Package %S doesn't exist in the current project." s } end @@ -437,7 +438,7 @@ end = struct | node -> node | exception Exit -> Exn.code_error "Super_context.Env.get called on invalid directory" - [ "dir", Path.sexp_of_t dir ] + [ "dir", Path.to_sexp dir ] let ocaml_flags t ~dir = let rec loop t node = @@ -753,7 +754,7 @@ module Deps = struct Build.paths_glob ~loc ~dir (Re.compile re) >>^ Path.Set.to_list | Error (_pos, msg) -> - Loc.fail (String_with_vars.loc s) "invalid glob: %s" msg + Errors.fail (String_with_vars.loc s) "invalid glob: %s" msg end | Source_tree s -> let path = expand_vars_path t ~scope ~dir s in @@ -836,9 +837,9 @@ module Action = struct begin match Dune_file.Bindings.find deps_written_by_user key with | None -> Exn.code_error "Local named variable not present in named deps" - [ "pform", String_with_vars.Var.sexp_of_t pform + [ "pform", String_with_vars.Var.to_sexp pform ; "deps_written_by_user", - Dune_file.Bindings.sexp_of_t Path.sexp_of_t deps_written_by_user + Dune_file.Bindings.to_sexp Path.to_sexp deps_written_by_user ] | Some x -> Value.L.paths x end @@ -855,13 +856,13 @@ module Action = struct assert false | Unnamed v :: _ -> [Path v] | [] -> - Loc.warn loc "Variable '%s' used with no explicit \ + Errors.warn loc "Variable '%s' used with no explicit \ dependencies@." key; [Value.String ""] end | _ -> Exn.code_error "Unexpected variable in step2" - ["var", String_with_vars.Var.sexp_of_t pform])) + ["var", String_with_vars.Var.to_sexp pform])) let run sctx ~loc ~bindings ~dir ~dep_kind ~targets:targets_written_by_user ~targets_dir ~scope t @@ -873,7 +874,7 @@ module Action = struct | [] -> () | x :: _ -> let loc = String_with_vars.loc x in - Loc.warn loc + Errors.warn loc "Aliases must not have targets, this target will be ignored.\n\ This will become an error in the future."; end; @@ -899,7 +900,7 @@ module Action = struct let targets = Path.Set.to_list targets in List.iter targets ~f:(fun target -> if Path.parent_exn target <> targets_dir then - Loc.fail loc + Errors.fail loc "This action has targets in a different directory than the current \ one, this is not allowed by dune at the moment:\n%s" (List.map targets ~f:(fun target -> diff --git a/src/super_context.mli b/src/super_context.mli index 763b31cd..32d4e60b 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -5,6 +5,7 @@ Super context are used for generating rules. *) +open! Stdune open Import open Dune_file @@ -74,7 +75,7 @@ val ocaml_flags -> Ocaml_flags.t (** Dump a directory environment in a readable form *) -val dump_env : t -> dir:Path.t -> (unit, Sexp.t list) Build.t +val dump_env : t -> dir:Path.t -> (unit, Dsexp.t list) Build.t val find_scope_by_dir : t -> Path.t -> Scope.t val find_scope_by_name : t -> Dune_project.Name.t -> Scope.t @@ -150,7 +151,7 @@ val add_alias_action -> Build_system.Alias.t -> loc:Loc.t option -> ?locks:Path.t list - -> stamp:Sexp.t + -> stamp:_ -> (unit, Action.t) Build.t -> unit diff --git a/src/syntax.ml b/src/syntax.ml index aaa25212..21b1f43c 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -1,3 +1,4 @@ +open! Stdune open Import module Version = struct @@ -16,19 +17,21 @@ module Version = struct let to_string (a, b) = sprintf "%u.%u" a b - let sexp_of_t t = Sexp.unsafe_atom_of_string (to_string t) + let to_sexp t = Sexp.Atom (to_string t) - let t : t Sexp.Of_sexp.t = - let open Sexp.Of_sexp in + let dgen t = Dsexp.To_sexp.string (to_string t) + + let dparse : t Dsexp.Of_sexp.t = + let open Dsexp.Of_sexp in raw >>| function | Atom (loc, A s) -> begin try Scanf.sscanf s "%u.%u" (fun a b -> (a, b)) with _ -> - Loc.fail loc "Atom of the form NNN.NNN expected" + Errors.fail loc "Atom of the form NNN.NNN expected" end | sexp -> - of_sexp_error (Sexp.Ast.loc sexp) "Atom expected" + of_sexp_error (Dsexp.Ast.loc sexp) "Atom expected" let can_read ~parser_version:(parser_major, parser_minor) @@ -40,7 +43,7 @@ end module Supported_versions = struct type t = int Int.Map.t - let sexp_of_t (t : t) = + let to_sexp (t : t) = let open Sexp.To_sexp in (list (pair int int)) (Int.Map.to_list t) @@ -53,7 +56,7 @@ module Supported_versions = struct | Error _ -> Exn.code_error "Syntax.create" - [ "versions", Sexp.To_sexp.list Version.sexp_of_t l ] + [ "versions", Sexp.To_sexp.list Version.to_sexp l ] let greatest_supported_version t = Option.value_exn (Int.Map.max_binding t) @@ -76,15 +79,15 @@ type t = module Error = struct let since loc t ver ~what = - Loc.fail loc "%s is only available since version %s of %s" + Errors.fail loc "%s is only available since version %s of %s" what (Version.to_string ver) t.desc let renamed_in loc t ver ~what ~to_ = - Loc.fail loc "%s was renamed to '%s' in the %s version of %s" + Errors.fail loc "%s was renamed to '%s' in the %s version of %s" what to_ (Version.to_string ver) t.desc let deleted_in loc t ?repl ver ~what = - Loc.fail loc "%s was deleted in version %s of %s%s" + Errors.fail loc "%s was deleted in version %s of %s%s" what (Version.to_string ver) t.desc (match repl with | None -> "" @@ -95,7 +98,7 @@ end let create ~name ~desc supported_versions = { name ; desc - ; key = Univ_map.Key.create ~name Version.sexp_of_t + ; key = Univ_map.Key.create ~name Version.to_sexp ; supported_versions = Supported_versions.make supported_versions } @@ -103,7 +106,7 @@ let name t = t.name let check_supported t (loc, ver) = if not (Supported_versions.is_supported t.supported_versions ver) then - Loc.fail loc "Version %s of %s is not supported.\n\ + Errors.fail loc "Version %s of %s is not supported.\n\ Supported versions:\n\ %s" (Version.to_string ver) t.name @@ -123,7 +126,7 @@ let greatest_supported_version t = let key t = t.key -open Sexp.Of_sexp +open Dsexp.Of_sexp let set t ver parser = set t.key ver parser @@ -135,8 +138,8 @@ let get_exn t = get_all >>| fun context -> Exn.code_error "Syntax identifier is unset" [ "name", Sexp.To_sexp.string t.name - ; "supported_versions", Supported_versions.sexp_of_t t.supported_versions - ; "context", Univ_map.sexp_of_t context + ; "supported_versions", Supported_versions.to_sexp t.supported_versions + ; "context", Univ_map.to_sexp context ] let desc () = diff --git a/src/syntax.mli b/src/syntax.mli index 6c81e2c2..94992b9f 100644 --- a/src/syntax.mli +++ b/src/syntax.mli @@ -1,6 +1,6 @@ (** Management of syntaxes *) -open Stdune +open! Stdune module Version : sig (** A syntax version. @@ -10,7 +10,9 @@ module Version : sig [Z <= Y]. *) type t = int * int - include Sexp.Sexpable with type t := t + include Dsexp.Sexpable with type t := t + + val to_sexp : t Sexp.To_sexp.t val to_string : t -> string @@ -57,24 +59,24 @@ val greatest_supported_version : t -> Version.t (** Indicate the field/constructor being parsed was deleted in the given version *) -val deleted_in : t -> Version.t -> (unit, _) Sexp.Of_sexp.parser +val deleted_in : t -> Version.t -> (unit, _) Dsexp.Of_sexp.parser (** Indicate the field/constructor being parsed was renamed in the given version *) -val renamed_in : t -> Version.t -> to_:string -> (unit, _) Sexp.Of_sexp.parser +val renamed_in : t -> Version.t -> to_:string -> (unit, _) Dsexp.Of_sexp.parser (** Indicate the field/constructor being parsed was introduced in the given version *) -val since : t -> Version.t -> (unit, _) Sexp.Of_sexp.parser +val since : t -> Version.t -> (unit, _) Dsexp.Of_sexp.parser (** {2 Low-level functions} *) val set : t -> Version.t - -> ('a, 'k) Sexp.Of_sexp.parser - -> ('a, 'k) Sexp.Of_sexp.parser + -> ('a, 'k) Dsexp.Of_sexp.parser + -> ('a, 'k) Dsexp.Of_sexp.parser -val get_exn : t -> (Version.t, 'k) Sexp.Of_sexp.parser +val get_exn : t -> (Version.t, 'k) Dsexp.Of_sexp.parser val key : t -> Version.t Univ_map.Key.t diff --git a/src/top_closure.ml b/src/top_closure.ml index cec04979..4cfa698a 100644 --- a/src/top_closure.ml +++ b/src/top_closure.ml @@ -1,4 +1,4 @@ -open Import +open! Stdune module type Keys = sig type t diff --git a/src/top_closure.mli b/src/top_closure.mli index 867b5079..4efec53a 100644 --- a/src/top_closure.mli +++ b/src/top_closure.mli @@ -1,4 +1,4 @@ -open Stdune +open! Stdune module type Keys = sig type t diff --git a/src/usexp/import.ml b/src/usexp/import.ml deleted file mode 100644 index 32e337e0..00000000 --- a/src/usexp/import.ml +++ /dev/null @@ -1,26 +0,0 @@ -(* TODO get rid of this when inverting the deps between stdune and usexp *) - -module List = ListLabels -module String = struct - include StdLabels.String - - let split_on_char s ~on = - let rec loop i j = - if j = length s then - [sub s ~pos:i ~len:(j - i)] - else if s.[j] = on then - sub s ~pos:i ~len:(j - i) :: loop (j + 1) (j + 1) - else - loop i (j + 1) - in - loop 0 0 -end - -module Bytes = struct - include StdLabels.Bytes - - (* [blit_string] was forgotten from the labeled version in OCaml - 4.02—4.04. *) - let blit_string ~src ~src_pos ~dst ~dst_pos ~len = - Bytes.blit_string src src_pos dst dst_pos len -end diff --git a/src/usexp/loc.ml b/src/usexp/loc.ml deleted file mode 100644 index 54c9aeac..00000000 --- a/src/usexp/loc.ml +++ /dev/null @@ -1,23 +0,0 @@ -type t = - { start : Lexing.position - ; stop : Lexing.position - } - -let in_file fn = - let pos : Lexing.position = - { pos_fname = fn - ; pos_lnum = 1 - ; pos_cnum = 0 - ; pos_bol = 0 - } - in - { start = pos - ; stop = pos - } - -let none = in_file "" - -let of_lexbuf lexbuf : t = - { start = Lexing.lexeme_start_p lexbuf - ; stop = Lexing.lexeme_end_p lexbuf - } diff --git a/src/usexp/loc.mli b/src/usexp/loc.mli deleted file mode 100644 index 2526948e..00000000 --- a/src/usexp/loc.mli +++ /dev/null @@ -1,10 +0,0 @@ -type t = - { start : Lexing.position - ; stop : Lexing.position - } - -val in_file : string -> t - -val none : t - -val of_lexbuf : Lexing.lexbuf -> t diff --git a/src/usexp/sexp.ml b/src/usexp/sexp.ml deleted file mode 100644 index f8cbb38c..00000000 --- a/src/usexp/sexp.ml +++ /dev/null @@ -1,7 +0,0 @@ -include Types.Sexp - -let atom_or_quoted_string s = - if Atom.is_valid_dune s then - Atom (Atom.of_string s) - else - Quoted_string s diff --git a/src/usexp/sexp.mli b/src/usexp/sexp.mli deleted file mode 100644 index 94c45ca5..00000000 --- a/src/usexp/sexp.mli +++ /dev/null @@ -1,7 +0,0 @@ -type t = Types.Sexp.t = - | Atom of Atom.t - | Quoted_string of string - | List of t list - | Template of Types.Template.t - -val atom_or_quoted_string : string -> t diff --git a/src/usexp/usexp.ml b/src/usexp/usexp.ml deleted file mode 100644 index eb28b04a..00000000 --- a/src/usexp/usexp.ml +++ /dev/null @@ -1,255 +0,0 @@ -open Import - -module Loc = Loc -module Atom = Atom -module Template = Template - -type syntax = Atom.syntax = Jbuild | Dune - -include Sexp - -let atom s = Atom (Atom.of_string s) - -let unsafe_atom_of_string s = atom s - -let rec to_string t ~syntax = - match t with - | Atom a -> Atom.print a syntax - | Quoted_string s -> Escape.quoted s ~syntax - | List l -> - Printf.sprintf "(%s)" (List.map l ~f:(to_string ~syntax) - |> String.concat ~sep:" ") - | Template t -> Template.to_string t ~syntax - -let rec pp syntax ppf = function - | Atom s -> - Format.pp_print_string ppf (Atom.print s syntax) - | Quoted_string s -> - Format.pp_print_string ppf (Escape.quoted ~syntax s) - | List [] -> - Format.pp_print_string ppf "()" - | List (first :: rest) -> - Format.pp_open_box ppf 1; - Format.pp_print_string ppf "("; - Format.pp_open_hvbox ppf 0; - pp syntax ppf first; - List.iter rest ~f:(fun sexp -> - Format.pp_print_space ppf (); - pp syntax ppf sexp); - Format.pp_close_box ppf (); - Format.pp_print_string ppf ")"; - Format.pp_close_box ppf () - | Template t -> Template.pp syntax ppf t - -let pp_quoted = - let rec loop = function - | Atom (A s) as t -> - if Atom.is_valid_dune s then - t - else - Quoted_string s - | List xs -> List (List.map ~f:loop xs) - | (Quoted_string _ | Template _) as t -> t - in - fun ppf t -> pp Dune ppf (loop t) - -let pp_print_quoted_string ppf s = - let syntax = Dune in - if String.contains s '\n' then begin - match String.split_on_char s ~on:'\n' with - | [] -> Format.pp_print_string ppf (Escape.quoted ~syntax s) - | first :: rest -> - Format.fprintf ppf "@[\"@{%s" - (Escape.escaped ~syntax first); - List.iter rest ~f:(fun s -> - Format.fprintf ppf "@,\\n%s" (Escape.escaped ~syntax s)); - Format.fprintf ppf "@}\"@]" - end else - Format.pp_print_string ppf (Escape.quoted ~syntax s) - -let rec pp_split_strings ppf = function - | Atom s -> Format.pp_print_string ppf (Atom.print s Atom.Dune) - | Quoted_string s -> pp_print_quoted_string ppf s - | List [] -> - Format.pp_print_string ppf "()" - | List (first :: rest) -> - Format.pp_open_box ppf 1; - Format.pp_print_string ppf "("; - Format.pp_open_hvbox ppf 0; - pp_split_strings ppf first; - List.iter rest ~f:(fun sexp -> - Format.pp_print_space ppf (); - pp_split_strings ppf sexp); - Format.pp_close_box ppf (); - Format.pp_print_string ppf ")"; - Format.pp_close_box ppf () - | Template t -> Template.pp_split_strings ppf t - -type formatter_state = - | In_atom - | In_makefile_action - | In_makefile_stuff - -let prepare_formatter ppf = - let state = ref [] in - Format.pp_set_mark_tags ppf true; - let ofuncs = Format.pp_get_formatter_out_functions ppf () in - let tfuncs = Format.pp_get_formatter_tag_functions ppf () in - Format.pp_set_formatter_tag_functions ppf - { tfuncs with - mark_open_tag = (function - | "atom" -> state := In_atom :: !state; "" - | "makefile-action" -> state := In_makefile_action :: !state; "" - | "makefile-stuff" -> state := In_makefile_stuff :: !state; "" - | s -> tfuncs.mark_open_tag s) - ; mark_close_tag = (function - | "atom" | "makefile-action" | "makefile-stuff" -> state := List.tl !state; "" - | s -> tfuncs.mark_close_tag s) - }; - Format.pp_set_formatter_out_functions ppf - { ofuncs with - out_newline = (fun () -> - match !state with - | [In_atom; In_makefile_action] -> - ofuncs.out_string "\\\n\t" 0 3 - | [In_atom] -> - ofuncs.out_string "\\\n" 0 2 - | [In_makefile_action] -> - ofuncs.out_string " \\\n\t" 0 4 - | [In_makefile_stuff] -> - ofuncs.out_string " \\\n" 0 3 - | [] -> - ofuncs.out_string "\n" 0 1 - | _ -> assert false) - ; out_spaces = (fun n -> - ofuncs.out_spaces - (match !state with - | In_atom :: _ -> max 0 (n - 2) - | _ -> n)) - } - -module Ast = struct - type t = - | Atom of Loc.t * Atom.t - | Quoted_string of Loc.t * string - | Template of Template.t - | List of Loc.t * t list - - let atom_or_quoted_string loc s = - match Sexp.atom_or_quoted_string s with - | Atom a -> Atom (loc, a) - | Quoted_string s -> Quoted_string (loc, s) - | Template _ - | List _ -> assert false - - let loc (Atom (loc, _) | Quoted_string (loc, _) | List (loc, _) - | Template { loc ; _ }) = loc - - let rec remove_locs t : Sexp.t = - match t with - | Template t -> Template (Template.remove_locs t) - | Atom (_, s) -> Atom s - | Quoted_string (_, s) -> Quoted_string s - | List (_, l) -> List (List.map l ~f:remove_locs) -end - -let rec add_loc t ~loc : Ast.t = - match t with - | Atom s -> Atom (loc, s) - | Quoted_string s -> Quoted_string (loc, s) - | List l -> List (loc, List.map l ~f:(add_loc ~loc)) - | Template t -> Template { t with loc } - -module Parse_error = struct - include Lexer.Error - - let loc t : Loc.t = { start = t.start; stop = t.stop } - let message t = t.message -end -exception Parse_error = Lexer.Error - -module Lexer = Lexer - -module Parser = struct - let error (loc : Loc.t) message = - raise (Parse_error - { start = loc.start - ; stop = loc.stop - ; message - }) - - module Mode = struct - type 'a t = - | Single : Ast.t t - | Many : Ast.t list t - | Many_as_one : Ast.t t - - let make_result : type a. a t -> Lexing.lexbuf -> Ast.t list -> a - = fun t lexbuf sexps -> - match t with - | Single -> begin - match sexps with - | [sexp] -> sexp - | [] -> error (Loc.of_lexbuf lexbuf) "no s-expression found in input" - | _ :: sexp :: _ -> - error (Ast.loc sexp) "too many s-expressions found in input" - end - | Many -> sexps - | Many_as_one -> - match sexps with - | [] -> List (Loc.in_file lexbuf.lex_curr_p.pos_fname, []) - | x :: l -> - let last = List.fold_left l ~init:x ~f:(fun _ x -> x) in - let loc = { (Ast.loc x) with stop = (Ast.loc last).stop } in - List (loc, x :: l) - end - - let rec loop depth lexer lexbuf acc = - match (lexer lexbuf : Lexer.Token.t) with - | Atom a -> - let loc = Loc.of_lexbuf lexbuf in - loop depth lexer lexbuf (Ast.Atom (loc, a) :: acc) - | Quoted_string s -> - let loc = Loc.of_lexbuf lexbuf in - loop depth lexer lexbuf (Quoted_string (loc, s) :: acc) - | Template t -> - let loc = Loc.of_lexbuf lexbuf in - loop depth lexer lexbuf (Template { t with loc } :: acc) - | Lparen -> - let start = Lexing.lexeme_start_p lexbuf in - let sexps = loop (depth + 1) lexer lexbuf [] in - let stop = Lexing.lexeme_end_p lexbuf in - loop depth lexer lexbuf (List ({ start; stop }, sexps) :: acc) - | Rparen -> - if depth = 0 then - error (Loc.of_lexbuf lexbuf) - "right parenthesis without matching left parenthesis"; - List.rev acc - | Sexp_comment -> - let sexps = - let loc = Loc.of_lexbuf lexbuf in - match loop depth lexer lexbuf [] with - | _ :: sexps -> sexps - | [] -> error loc "s-expression missing after #;" - in - List.rev_append acc sexps - | Eof -> - if depth > 0 then - error (Loc.of_lexbuf lexbuf) - "unclosed parenthesis at end of input"; - List.rev acc - - let parse ~mode ?(lexer=Lexer.token) lexbuf = - loop 0 lexer lexbuf [] - |> Mode.make_result mode lexbuf -end - -let parse_string ~fname ~mode ?lexer str = - let lb = Lexing.from_string str in - lb.lex_curr_p <- - { pos_fname = fname - ; pos_lnum = 1 - ; pos_bol = 0 - ; pos_cnum = 0 - }; - Parser.parse ~mode ?lexer lb diff --git a/src/usexp/usexp.mli b/src/usexp/usexp.mli deleted file mode 100644 index 31810267..00000000 --- a/src/usexp/usexp.mli +++ /dev/null @@ -1,158 +0,0 @@ -(** Parsing of s-expressions. - - This library is internal to jbuilder and guarantees no API stability.*) - -type syntax = Jbuild | Dune - -module Atom : sig - type t = private A of string [@@unboxed] - - val is_valid : t -> syntax -> bool - - val of_string : string -> t - val to_string : t -> string - - val of_int : int -> t - val of_float : float -> t - val of_bool : bool -> t - val of_int64 : Int64.t -> t - val of_digest : Digest.t -> t -end - -module Loc : sig - type t = - { start : Lexing.position - ; stop : Lexing.position - } - - val in_file : string -> t - - val none : t - - val of_lexbuf : Lexing.lexbuf -> t -end - -module Template : sig - type var_syntax = Dollar_brace | Dollar_paren | Percent - - type var = - { loc: Loc.t - ; name: string - ; payload: string option - ; syntax: var_syntax - } - - type part = - | Text of string - | Var of var - - type t = - { quoted: bool - ; parts: part list - ; loc: Loc.t - } - - val string_of_var : var -> string -end - -(** The S-expression type *) -type t = - | Atom of Atom.t - | Quoted_string of string - | List of t list - | Template of Template.t - -val atom : string -> t -(** [atom s] convert the string [s] to an Atom. - @raise Invalid_argument if [s] does not satisfy [Atom.is_valid s]. *) - -val atom_or_quoted_string : string -> t - -val unsafe_atom_of_string : string -> t - -(** Serialize a S-expression *) -val to_string : t -> syntax:syntax -> string - -(** Serialize a S-expression using indentation to improve readability *) -val pp : syntax -> Format.formatter -> t -> unit - -(** Serialization that never fails because it quotes atoms when necessary - TODO remove this once we have a proper sexp type *) -val pp_quoted : Format.formatter -> t -> unit - -(** Same as [pp ~syntax:Dune], but split long strings. The formatter - must have been prepared with [prepare_formatter]. *) -val pp_split_strings : Format.formatter -> t -> unit - -(** Prepare a formatter for [pp_split_strings]. Additionaly the - formatter escape newlines when the tags "makefile-action" or - "makefile-stuff" are active. *) -val prepare_formatter : Format.formatter -> unit - -(** Abstract syntax tree *) -module Ast : sig - type sexp = t - type t = - | Atom of Loc.t * Atom.t - | Quoted_string of Loc.t * string - | Template of Template.t - | List of Loc.t * t list - - val atom_or_quoted_string : Loc.t -> string -> t - - val loc : t -> Loc.t - - val remove_locs : t -> sexp -end with type sexp := t - -val add_loc : t -> loc:Loc.t -> Ast.t - -module Parse_error : sig - type t - - val loc : t -> Loc.t - val message : t -> string -end - -(** Exception raised in case of a parsing error *) -exception Parse_error of Parse_error.t - -module Lexer : sig - module Token : sig - type t = - | Atom of Atom.t - | Quoted_string of string - | Lparen - | Rparen - | Sexp_comment - | Eof - | Template of Template.t - end - - type t = Lexing.lexbuf -> Token.t - - val token : t - val jbuild_token : t -end - -module Parser : sig - module Mode : sig - type 'a t = - | Single : Ast.t t - | Many : Ast.t list t - | Many_as_one : Ast.t t - end - - val parse - : mode:'a Mode.t - -> ?lexer:Lexer.t - -> Lexing.lexbuf - -> 'a -end - -val parse_string - : fname:string - -> mode:'a Parser.Mode.t - -> ?lexer:Lexer.t - -> string - -> 'a diff --git a/src/utils.ml b/src/utils.ml index 531a5d70..0f500011 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -1,3 +1,4 @@ +open! Stdune open Import let system_shell_exn = @@ -114,7 +115,7 @@ let executable_object_directory ~dir name = Path.relative dir ("." ^ name ^ ".eobjs") let program_not_found ?context ?hint ~loc prog = - Loc.fail_opt loc + Errors.fail_opt loc "@{Error@}: Program %s not found in the tree or in PATH%s%a" (String.maybe_quoted prog) (match context with diff --git a/src/utils.mli b/src/utils.mli index e1789cda..c6bd83d4 100644 --- a/src/utils.mli +++ b/src/utils.mli @@ -1,6 +1,6 @@ (** Utilities that can't go in [Import] *) -open! Import +open! Stdune (** Return the absolute path to the shell and the argument to pass it (-c or /c). Raise in case in cannot be found. *) diff --git a/src/utop.ml b/src/utop.ml index 851a5ba1..c70f71f4 100644 --- a/src/utop.ml +++ b/src/utop.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Dune_file open Build.O diff --git a/src/utop.mli b/src/utop.mli index 29b71c49..47d376f6 100644 --- a/src/utop.mli +++ b/src/utop.mli @@ -1,6 +1,6 @@ (** Utop rules *) -open Stdune +open! Stdune val utop_exe : Path.t -> Path.t (** Return the path of the utop bytecode binary inside a directory where diff --git a/src/value.ml b/src/value.ml index 45574dbf..c4f82949 100644 --- a/src/value.ml +++ b/src/value.ml @@ -1,3 +1,4 @@ +open! Stdune open Import type t = @@ -5,12 +6,12 @@ type t = | Dir of Path.t | Path of Path.t -let sexp_of_t = +let to_sexp = let open Sexp.To_sexp in function | String s -> (pair string string) ("string", s) - | Path p -> (pair string Path.sexp_of_t) ("path", p) - | Dir p -> (pair string Path.sexp_of_t) ("dir", p) + | Path p -> (pair string Path.to_sexp) ("path", p) + | Dir p -> (pair string Path.to_sexp) ("dir", p) let string_of_path ~dir p = Path.reach ~from:dir p diff --git a/src/value.mli b/src/value.mli index b5f90fef..31868c45 100644 --- a/src/value.mli +++ b/src/value.mli @@ -1,11 +1,11 @@ -open Stdune +open! Stdune type t = | String of string | Dir of Path.t | Path of Path.t -val sexp_of_t : t Sexp.To_sexp.t +val to_sexp : t Sexp.To_sexp.t val to_string : t -> dir:Path.t -> string diff --git a/src/variant.ml b/src/variant.ml index f1968d34..0a3933b4 100644 --- a/src/variant.ml +++ b/src/variant.ml @@ -1,4 +1,4 @@ -open Stdune +open! Stdune include Interned.Make(struct let initial_size = 256 diff --git a/src/versioned_file.ml b/src/versioned_file.ml index 03e18087..0fb3c1b2 100644 --- a/src/versioned_file.ml +++ b/src/versioned_file.ml @@ -1,3 +1,4 @@ +open! Stdune open Import module type S = sig @@ -14,11 +15,11 @@ module type S = sig end val get_exn : string -> Instance.t end - val load : Path.t -> f:(Lang.Instance.t -> 'a Sexp.Of_sexp.t) -> 'a + val load : Path.t -> f:(Lang.Instance.t -> 'a Dsexp.Of_sexp.t) -> 'a val parse_contents : Lexing.lexbuf -> Dune_lexer.first_line - -> f:(Lang.Instance.t -> 'a Sexp.Of_sexp.t) + -> f:(Lang.Instance.t -> 'a Dsexp.Of_sexp.t) -> 'a end @@ -53,11 +54,11 @@ module Make(Data : sig type t end) = struct } = first_line in let ver = - Sexp.Of_sexp.parse Syntax.Version.t Univ_map.empty - (Atom (ver_loc, Sexp.Atom.of_string ver)) in + Dsexp.Of_sexp.parse Syntax.Version.dparse Univ_map.empty + (Atom (ver_loc, Dsexp.Atom.of_string ver)) in match Hashtbl.find langs name with | None -> - Loc.fail name_loc "Unknown language %S.%s" name + Errors.fail name_loc "Unknown language %S.%s" name (hint name (Hashtbl.keys langs)) | Some t -> Syntax.check_supported t.syntax (ver_loc, ver); @@ -76,11 +77,11 @@ module Make(Data : sig type t end) = struct let parse_contents lb first_line ~f = let lang = Lang.parse first_line in - let sexp = Sexp.Parser.parse lb ~mode:Many_as_one in + let sexp = Dsexp.Parser.parse lb ~mode:Many_as_one in let parsing_context = Univ_map.singleton (Syntax.key lang.syntax) lang.version in - Sexp.Of_sexp.parse (Sexp.Of_sexp.enter (f lang)) parsing_context sexp + Dsexp.Of_sexp.parse (Dsexp.Of_sexp.enter (f lang)) parsing_context sexp let load fn ~f = Io.with_lexbuf_from_file fn ~f:(fun lb -> diff --git a/src/versioned_file.mli b/src/versioned_file.mli index 6d8833c6..72926d51 100644 --- a/src/versioned_file.mli +++ b/src/versioned_file.mli @@ -1,6 +1,6 @@ (** Implementation of versioned files *) -open Stdune +open! Stdune module type S = sig type data @@ -30,14 +30,14 @@ module type S = sig (** [load fn ~f] loads a versioned file. It parses the first line, looks up the language, checks that the version is supported and parses the rest of the file with [f]. *) - val load : Path.t -> f:(Lang.Instance.t -> 'a Sexp.Of_sexp.t) -> 'a + val load : Path.t -> f:(Lang.Instance.t -> 'a Dsexp.Of_sexp.t) -> 'a (** Parse the contents of a versioned file after the first line has been read. *) val parse_contents : Lexing.lexbuf -> Dune_lexer.first_line - -> f:(Lang.Instance.t -> 'a Sexp.Of_sexp.t) + -> f:(Lang.Instance.t -> 'a Dsexp.Of_sexp.t) -> 'a end diff --git a/src/vfile_kind.ml b/src/vfile_kind.ml index 2cf8a3e8..721b773a 100644 --- a/src/vfile_kind.ml +++ b/src/vfile_kind.ml @@ -1,3 +1,4 @@ +open! Stdune open Import module Id = struct @@ -45,7 +46,7 @@ let eq (type a) (type b) module Make (T : sig type t - val t : t Sexp.To_sexp.t + val dgen : t Dsexp.To_sexp.t val name : string end) : S with type t = T.t = @@ -53,7 +54,7 @@ struct type t = T.t (* XXX dune dump should make use of this *) - let _t = T.t + let _t = T.dgen module P = Utils.Persistent(struct type nonrec t = t diff --git a/src/vfile_kind.mli b/src/vfile_kind.mli index c4351ff5..aa054903 100644 --- a/src/vfile_kind.mli +++ b/src/vfile_kind.mli @@ -22,7 +22,7 @@ val eq : 'a t -> 'b t -> ('a, 'b) eq option module Make (T : sig type t - val t : t Sexp.To_sexp.t + val dgen : t Dsexp.To_sexp.t val name : string end) : S with type t = T.t diff --git a/src/watermarks.ml b/src/watermarks.ml index aff2ef61..1ab915ae 100644 --- a/src/watermarks.ml +++ b/src/watermarks.ml @@ -1,3 +1,4 @@ +open! Stdune open Import open Fiber.O @@ -130,7 +131,7 @@ let subst_string s path ~map = loop (i + 1) acc | Some (Error msg) -> let loc = loc_of_offset ~ofs:start ~len:(i + 1 - start) in - Loc.fail loc "%s" msg + Errors.fail loc "%s" msg end | _ -> loop (i + 1) acc in diff --git a/src/workspace.ml b/src/workspace.ml index aec4cf56..0df91bcd 100644 --- a/src/workspace.ml +++ b/src/workspace.ml @@ -1,4 +1,4 @@ -open Import +open! Stdune open Stanza.Of_sexp (* workspace files use the same version numbers as dune-project files @@ -8,7 +8,7 @@ let syntax = Stanza.syntax let env_field = field_o "env" (Syntax.since syntax (1, 1) >>= fun () -> - Dune_env.Stanza.t) + Dune_env.Stanza.dparse) module Context = struct module Target = struct @@ -122,7 +122,7 @@ module Context = struct (* jbuild-workspace files *) (peek_exn >>= function | List (_, List _ :: _) -> - Sexp.Of_sexp.record (Opam.t ~profile ~x) >>| fun x -> Opam x + Dsexp.Of_sexp.record (Opam.t ~profile ~x) >>| fun x -> Opam x | _ -> t ~profile ~x) ~dune:(t ~profile ~x) @@ -171,13 +171,13 @@ let t ?x ?profile:cmdline_profile () = List.fold_left contexts ~init:None ~f:(fun acc ctx -> let name = Context.name ctx in if String.Set.mem !defined_names name then - Loc.fail (Context.loc ctx) + Errors.fail (Context.loc ctx) "second definition of build context %S" name; defined_names := String.Set.union !defined_names (String.Set.of_list (Context.all_names ctx)); match ctx, acc with | Opam { merlin = true; _ }, Some _ -> - Loc.fail (Context.loc ctx) + Errors.fail (Context.loc ctx) "you can only have one context for merlin" | Opam { merlin = true; _ }, None -> Some name @@ -224,7 +224,7 @@ let load ?x ?profile p = parse_contents lb first_line ~f:(fun _lang -> t ?x ?profile ())) | Jbuilder -> let sexp = - Io.Sexp.load p ~mode:Many_as_one ~lexer:Sexp.Lexer.jbuild_token + Dsexp.Io.load p ~mode:Many_as_one ~lexer:Dsexp.Lexer.jbuild_token in parse (enter (t ?x ?profile ())) diff --git a/src/workspace.mli b/src/workspace.mli index 9b3ec7d8..c4019039 100644 --- a/src/workspace.mli +++ b/src/workspace.mli @@ -1,5 +1,6 @@ (** Workspaces definitions *) +open! Stdune open! Import module Context : sig diff --git a/test/blackbox-tests/dune b/test/blackbox-tests/dune index 2586e096..928979ff 100644 --- a/test/blackbox-tests/dune +++ b/test/blackbox-tests/dune @@ -9,7 +9,7 @@ (executable (name gen_tests) - (libraries stdune usexp) + (libraries stdune dsexp) (modules gen_tests)) (include dune.inc) diff --git a/test/blackbox-tests/gen_tests.ml b/test/blackbox-tests/gen_tests.ml index 02925545..2487e649 100644 --- a/test/blackbox-tests/gen_tests.ml +++ b/test/blackbox-tests/gen_tests.ml @@ -1,27 +1,27 @@ -open Stdune +open! Stdune let sprintf = Printf.sprintf module Sexp = struct let fields fields = List.map fields ~f:(fun (k, s) -> - Usexp.List (Usexp.atom k :: s)) + Dsexp.List (Dsexp.atom k :: s)) let strings fields = - Usexp.List (List.map fields ~f:Usexp.atom_or_quoted_string) + Dsexp.List (List.map fields ~f:Dsexp.atom_or_quoted_string) let constr name args = - Usexp.List (Usexp.atom name :: args) + Dsexp.List (Dsexp.atom name :: args) let parse s = - Usexp.parse_string ~fname:"gen_tests.ml" ~mode:Single s - |> Usexp.Ast.remove_locs + Dsexp.parse_string ~fname:"gen_tests.ml" ~mode:Single s + |> Dsexp.Ast.remove_locs end module Platform = struct type t = Win | Mac - open Usexp + open Dsexp let to_string = function | Win -> "win" @@ -44,7 +44,7 @@ end let alias ?enabled_if ?action name ~deps = Sexp.constr "alias" (Sexp.fields ( - [ "name", [Usexp.atom name] + [ "name", [Dsexp.atom name] ; "deps", deps ] @ (match action with | None -> [] @@ -56,7 +56,7 @@ let alias ?enabled_if ?action name ~deps = module Test = struct type t = { name : string - ; env : (string * Usexp.t) option + ; env : (string * Dsexp.t) option ; skip_ocaml : string option ; skip_platforms : Platform.t list ; enabled : bool @@ -76,7 +76,7 @@ module Test = struct } let pp_sexp fmt t = - let open Usexp in + let open Dsexp in let skip_version = match t.skip_ocaml with | None -> [] @@ -89,10 +89,10 @@ module Test = struct ; atom (sprintf "test-cases/%s" t.name) ; List [ atom "progn" - ; Usexp.List + ; Dsexp.List ([ atom "run" ; Sexp.parse "%{exe:cram.exe}" ] - @ (List.map ~f:Usexp.atom_or_quoted_string + @ (List.map ~f:Dsexp.atom_or_quoted_string (skip_version @ ["-test"; "run.t"]))) ; Sexp.strings ["diff?"; "run.t"; "run.t.corrected"] ] @@ -115,7 +115,7 @@ module Test = struct ; sprintf "test-cases/%s" t.name] ] ) ~action - |> Usexp.pp Dune fmt + |> Dsexp.pp Dune fmt end let exclusions = @@ -123,7 +123,7 @@ let exclusions = let odoc = make ~external_deps:true ~skip_ocaml:"4.02.3" in [ make "js_of_ocaml" ~external_deps:true ~js:true ~env:("NODE", Sexp.parse "%{bin:node}") - ; make "github25" ~env:("OCAMLPATH", Usexp.atom "./findlib-packages") + ; make "github25" ~env:("OCAMLPATH", Dsexp.atom "./findlib-packages") ; odoc "odoc" ; odoc "odoc-unique-mlds" ; odoc "github717-odoc-index" @@ -160,7 +160,7 @@ let pp_group fmt (name, tests) = alias name ~deps:( (List.map tests ~f:(fun (t : Test.t) -> Sexp.strings ["alias"; t.name]))) - |> Usexp.pp Dune fmt + |> Dsexp.pp Dune fmt let () = let tests = Lazy.force all_tests in diff --git a/test/blackbox-tests/test-cases/output-obj/run.t b/test/blackbox-tests/test-cases/output-obj/run.t index a92d9cb3..01b741e1 100644 --- a/test/blackbox-tests/test-cases/output-obj/run.t +++ b/test/blackbox-tests/test-cases/output-obj/run.t @@ -13,10 +13,10 @@ $ dune build @runtest dynamic alias runtest - OK: ./dynamic.exe ./test.bc.so - static alias runtest - OK: ./static.bc + OK: ./dynamic.exe ./test$ext_dll static alias runtest OK: ./static.exe + static alias runtest + OK: ./static.bc dynamic alias runtest - OK: ./dynamic.exe ./test$ext_dll + OK: ./dynamic.exe ./test.bc.so diff --git a/test/blackbox-tests/test-cases/shadow-bindings/dune b/test/blackbox-tests/test-cases/shadow-bindings/dune index 48f0bd40..8acf24bc 100644 --- a/test/blackbox-tests/test-cases/shadow-bindings/dune +++ b/test/blackbox-tests/test-cases/shadow-bindings/dune @@ -2,7 +2,7 @@ (alias (name runtest) (deps (:workspace_root foo)) - (action (echo %{workspace_root}))) + (action (echo "%{workspace_root}\n"))) (alias (name runtest) diff --git a/test/blackbox-tests/test-cases/shadow-bindings/run.t b/test/blackbox-tests/test-cases/shadow-bindings/run.t index ed2707d6..285e17f1 100644 --- a/test/blackbox-tests/test-cases/shadow-bindings/run.t +++ b/test/blackbox-tests/test-cases/shadow-bindings/run.t @@ -1,5 +1,5 @@ Bindings introduced by user dependencies should shadow existing bindings $ dune runtest - xb foo + xb diff --git a/test/blackbox-tests/test-cases/tests-stanza/run.t b/test/blackbox-tests/test-cases/tests-stanza/run.t index 93ebf2bf..a06e5e3d 100644 --- a/test/blackbox-tests/test-cases/tests-stanza/run.t +++ b/test/blackbox-tests/test-cases/tests-stanza/run.t @@ -7,12 +7,12 @@ singular test ocamldep .expect_test.eobjs/expect_test.ml.d ocamldep .expect_test.eobjs/regular_test.ml.d + ocamlc .expect_test.eobjs/expect_test.{cmi,cmo,cmt} + ocamlopt .expect_test.eobjs/expect_test.{cmx,o} + ocamlopt expect_test.exe + expect_test expect_test.output ocamlc .expect_test.eobjs/regular_test.{cmi,cmo,cmt} ocamlopt .expect_test.eobjs/regular_test.{cmx,o} ocamlopt regular_test.exe regular_test alias runtest regular test - ocamlc .expect_test.eobjs/expect_test.{cmi,cmo,cmt} - ocamlopt .expect_test.eobjs/expect_test.{cmx,o} - ocamlopt expect_test.exe - expect_test expect_test.output diff --git a/test/unit-tests/action.mlt b/test/unit-tests/action.mlt index 10b82a7e..82bf0999 100644 --- a/test/unit-tests/action.mlt +++ b/test/unit-tests/action.mlt @@ -2,8 +2,8 @@ #warnings "-40";; +open Stdune;; open Dune;; -open Import;; open Action.Infer.Outcome;; Stdune.Path.set_build_dir (Path.Kind.of_string "_build");; @@ -14,7 +14,7 @@ let infer (a : Action.t) = List.map (Path.Set.to_list x.targets) ~f:Path.to_string) [%%expect{| - : unit = () -val p : ?error_loc:Usexp.Loc.t -> string -> Path.t = +val p : ?error_loc:Stdune__Loc.t -> string -> Path.t = val infer : Action.t -> string list * string list = |}] diff --git a/test/unit-tests/dune b/test/unit-tests/dune index f2df88bf..8e3ac417 100644 --- a/test/unit-tests/dune +++ b/test/unit-tests/dune @@ -10,7 +10,7 @@ (executable (name sexp_tests) (modules sexp_tests) - (libraries stdune usexp)) + (libraries stdune dsexp)) (alias (name runtest) diff --git a/test/unit-tests/dune_file.mlt b/test/unit-tests/dune_file.mlt index ecf75c77..d4aeea76 100644 --- a/test/unit-tests/dune_file.mlt +++ b/test/unit-tests/dune_file.mlt @@ -1,18 +1,18 @@ (* -*- tuareg -*- *) open Dune;; -open Stdune;; +open! Stdune;; -let sexp_pp = Sexp.pp Dune;; +let sexp_pp = Dsexp.pp Dune;; #install_printer Dune_file.Mode_conf.pp;; #install_printer Binary_kind.pp;; #install_printer sexp_pp;; -(* Dune_file.Executables.Link_mode.t *) +(* Dune_file.Executables.Link_mode.dparse *) let test s = - Sexp.Of_sexp.parse Dune_file.Executables.Link_mode.t Univ_map.empty - (Sexp.parse_string ~fname:"" ~mode:Sexp.Parser.Mode.Single s) + Dsexp.Of_sexp.parse Dune_file.Executables.Link_mode.dparse Univ_map.empty + (Dsexp.parse_string ~fname:"" ~mode:Dsexp.Parser.Mode.Single s) [%%expect{| -val sexp_pp : Format.formatter -> Usexp.t -> unit = +val sexp_pp : Format.formatter -> Dsexp.t -> unit = val test : string -> Dune_file.Executables.Link_mode.t = |}] @@ -44,21 +44,21 @@ test "native" - : Dune_file.Executables.Link_mode.t = {mode = native; kind = exe} |}] -(* Dune_file.Executables.Link_mode.sexp_of_t *) +(* Dune_file.Executables.Link_mode.dgen *) let test l = - Dune_file.Executables.Link_mode.sexp_of_t l + Dune_file.Executables.Link_mode.dgen l [%%expect{| -val test : Dune_file.Executables.Link_mode.t -> Usexp.t = +val test : Dune_file.Executables.Link_mode.t -> Dsexp.t = |}] (* In the general case, modes are serialized as a list *) test {Dune_file.Executables.Link_mode.kind = Shared_object; mode = Byte } [%%expect{| -- : Usexp.t = (byte shared_object) +- : Dsexp.t = (byte shared_object) |}] (* But the specialized ones are serialized in the minimal version *) test Dune_file.Executables.Link_mode.exe [%%expect{| -- : Usexp.t = exe +- : Dsexp.t = exe |}] diff --git a/test/unit-tests/expect_test.mll b/test/unit-tests/expect_test.mll index 7d3de5ce..ddc29312 100644 --- a/test/unit-tests/expect_test.mll +++ b/test/unit-tests/expect_test.mll @@ -78,7 +78,7 @@ let main () = Toploop.initialize_toplevel_env (); List.iter - [ "src/usexp/.usexp.objs" + [ "src/dsexp/.dsexp.objs" ; "src/stdune/.stdune.objs" ; "src/.dune.objs" ] diff --git a/test/unit-tests/ocaml-config/gh637.ml b/test/unit-tests/ocaml-config/gh637.ml index d99396b7..b922c293 100644 --- a/test/unit-tests/ocaml-config/gh637.ml +++ b/test/unit-tests/ocaml-config/gh637.ml @@ -1,4 +1,4 @@ -open Stdune +open! Stdune let pwd = Sys.getcwd () diff --git a/test/unit-tests/path.mlt b/test/unit-tests/path.mlt index 0f47a2b8..d2ac95f5 100644 --- a/test/unit-tests/path.mlt +++ b/test/unit-tests/path.mlt @@ -1,5 +1,5 @@ (* -*- tuareg -*- *) -open Stdune;; +open! Stdune;; Path.set_root (Path.External.cwd ()); Path.set_build_dir (Path.Kind.of_string "_build"); @@ -221,9 +221,9 @@ Path.insert_after_build_dir_exn Path.root "foobar" Exception: Code_error (List - [Atom (A "Path.insert_after_build_dir_exn"); - List [Atom (A "path"); List [Atom (A "In_source_tree"); Atom (A ".")]]; - List [Atom (A "insert"); Atom (A "foobar")]]). + [Atom "Path.insert_after_build_dir_exn"; + List [Atom "path"; List [Atom "In_source_tree"; Atom "."]]; + List [Atom "insert"; Atom "foobar"]]). |}] Path.insert_after_build_dir_exn Path.build_dir "foobar" @@ -246,10 +246,9 @@ Path.append Path.build_dir (Path.relative Path.build_dir "foo") Exception: Code_error (List - [Quoted_string - "Path.append called with directory that's not in the source tree"; - List [Atom (A "a"); List [Atom (A "In_build_dir"); Atom (A ".")]]; - List [Atom (A "b"); List [Atom (A "In_build_dir"); Atom (A "foo")]]]). + [Atom "Path.append called with directory that's not in the source tree"; + List [Atom "a"; List [Atom "In_build_dir"; Atom "."]]; + List [Atom "b"; List [Atom "In_build_dir"; Atom "foo"]]]). |}] Path.append Path.root (Path.relative Path.build_dir "foo") @@ -257,10 +256,9 @@ Path.append Path.root (Path.relative Path.build_dir "foo") Exception: Code_error (List - [Quoted_string - "Path.append called with directory that's not in the source tree"; - List [Atom (A "a"); List [Atom (A "In_source_tree"); Atom (A ".")]]; - List [Atom (A "b"); List [Atom (A "In_build_dir"); Atom (A "foo")]]]). + [Atom "Path.append called with directory that's not in the source tree"; + List [Atom "a"; List [Atom "In_source_tree"; Atom "."]]; + List [Atom "b"; List [Atom "In_build_dir"; Atom "foo"]]]). |}] Path.append Path.root (Path.relative Path.root "foo") @@ -278,10 +276,9 @@ Path.append (Path.of_string "/root") (Path.relative Path.build_dir "foo") Exception: Code_error (List - [Quoted_string - "Path.append called with directory that's not in the source tree"; - List [Atom (A "a"); List [Atom (A "External"); Atom (A "/root")]]; - List [Atom (A "b"); List [Atom (A "In_build_dir"); Atom (A "foo")]]]). + [Atom "Path.append called with directory that's not in the source tree"; + List [Atom "a"; List [Atom "External"; Atom "/root"]]; + List [Atom "b"; List [Atom "In_build_dir"; Atom "foo"]]]). |}] Path.rm_rf (Path.of_string "/does/not/exist/foo/bar/baz") @@ -289,10 +286,9 @@ Path.rm_rf (Path.of_string "/does/not/exist/foo/bar/baz") Exception: Code_error (List - [Quoted_string "Path.rm_rf called on external dir"; + [Atom "Path.rm_rf called on external dir"; List - [Atom (A "t"); - List [Atom (A "External"); Atom (A "/does/not/exist/foo/bar/baz")]]]). + [Atom "t"; List [Atom "External"; Atom "/does/not/exist/foo/bar/baz"]]]). |}] Path.drop_build_context (Path.relative Path.build_dir "foo/bar") diff --git a/test/unit-tests/sexp.mlt b/test/unit-tests/sexp.mlt index 7776cec6..c245cb09 100644 --- a/test/unit-tests/sexp.mlt +++ b/test/unit-tests/sexp.mlt @@ -1,11 +1,11 @@ (* -*- tuareg -*- *) -open Stdune;; -open Sexp.Of_sexp;; +open! Stdune;; +open Dsexp.Of_sexp;; -let print_loc ppf (_ : Sexp.Loc.t) = Format.pp_print_string ppf "";; +let print_loc ppf (_ : Loc.t) = Format.pp_print_string ppf "";; #install_printer print_loc;; [%%expect{| -val print_loc : Format.formatter -> Usexp.Loc.t -> unit = +val print_loc : Format.formatter -> Loc.t -> unit = |}] Printexc.record_backtrace false;; @@ -13,14 +13,14 @@ Printexc.record_backtrace false;; - : unit = () |}] -let sexp = lazy (Sexp.parse_string ~fname:"" ~mode:Single {| +let sexp = lazy (Dsexp.parse_string ~fname:"" ~mode:Single {| ((foo 1) (foo 2)) |});; -Sexp.Ast.remove_locs (Lazy.force sexp) +Dsexp.Ast.remove_locs (Lazy.force sexp) [%%expect{| val sexp : ast lazy_t = -- : Usexp.t = +- : Dsexp.t = List [List [Atom (A "foo"); Atom (A "1")]; List [Atom (A "foo"); Atom (A "2")]] |}] @@ -51,14 +51,14 @@ type 'res parse_result = let parse s = let f ~lexer = try - Ok (Sexp.parse_string ~fname:"" ~mode:Many ~lexer s - |> List.map ~f:Sexp.Ast.remove_locs) + Ok (Dsexp.parse_string ~fname:"" ~mode:Many ~lexer s + |> List.map ~f:Dsexp.Ast.remove_locs) with - | Sexp.Parse_error e -> Error (Sexp.Parse_error.message e) + | Dsexp.Parse_error e -> Error (Dsexp.Parse_error.message e) | Invalid_argument e -> Error e in - let jbuild = f ~lexer:Sexp.Lexer.jbuild_token in - let dune = f ~lexer:Sexp.Lexer.token in + let jbuild = f ~lexer:Dsexp.Lexer.jbuild_token in + let dune = f ~lexer:Dsexp.Lexer.token in if jbuild <> dune then Different { jbuild; dune } else @@ -71,12 +71,12 @@ type 'res parse_result_diff = { type 'res parse_result = Same of ('res, string) Stdune.result | Different of 'res parse_result_diff -val parse : string -> Usexp.t list parse_result = +val parse : string -> Dsexp.t list parse_result = |}] parse {| # ## x##y x||y a#b|c#d copy# |} [%%expect{| -- : Usexp.t list parse_result = +- : Dsexp.t list parse_result = Same (Ok [Atom (A "#"); Atom (A "##"); Atom (A "x##y"); Atom (A "x||y"); @@ -86,7 +86,7 @@ Same parse {|x #| comment |# y|} [%%expect{| -- : Usexp.t list parse_result = +- : Dsexp.t list parse_result = Different {jbuild = Ok [Atom (A "x"); Atom (A "y")]; dune = @@ -97,7 +97,7 @@ Different parse {|x#|y|} [%%expect{| -- : Usexp.t list parse_result = +- : Dsexp.t list parse_result = Different {jbuild = Error "jbuild atoms cannot contain #|"; dune = Ok [Atom (A "x#|y")]} @@ -105,7 +105,7 @@ Different parse {|x|#y|} [%%expect{| -- : Usexp.t list parse_result = +- : Dsexp.t list parse_result = Different {jbuild = Error "jbuild atoms cannot contain |#"; dune = Ok [Atom (A "x|#y")]} @@ -113,56 +113,56 @@ Different parse {|"\a"|} [%%expect{| -- : Usexp.t list parse_result = +- : Dsexp.t list parse_result = Different {jbuild = Ok [Quoted_string "\\a"]; dune = Error "unknown escape sequence"} |}] parse {|"\%{x}"|} [%%expect{| -- : Usexp.t list parse_result = +- : Dsexp.t list parse_result = Different {jbuild = Ok [Quoted_string "\\%{x}"]; dune = Ok [Quoted_string "%{x}"]} |}] parse {|"$foo"|} [%%expect{| -- : Usexp.t list parse_result = Same (Ok [Quoted_string "$foo"]) +- : Dsexp.t list parse_result = Same (Ok [Quoted_string "$foo"]) |}] parse {|"%foo"|} [%%expect{| -- : Usexp.t list parse_result = Same (Ok [Quoted_string "%foo"]) +- : Dsexp.t list parse_result = Same (Ok [Quoted_string "%foo"]) |}] parse {|"bar%foo"|} [%%expect{| -- : Usexp.t list parse_result = Same (Ok [Quoted_string "bar%foo"]) +- : Dsexp.t list parse_result = Same (Ok [Quoted_string "bar%foo"]) |}] parse {|"bar$foo"|} [%%expect{| -- : Usexp.t list parse_result = Same (Ok [Quoted_string "bar$foo"]) +- : Dsexp.t list parse_result = Same (Ok [Quoted_string "bar$foo"]) |}] parse {|"%bar$foo%"|} [%%expect{| -- : Usexp.t list parse_result = Same (Ok [Quoted_string "%bar$foo%"]) +- : Dsexp.t list parse_result = Same (Ok [Quoted_string "%bar$foo%"]) |}] parse {|"$bar%foo%"|} [%%expect{| -- : Usexp.t list parse_result = Same (Ok [Quoted_string "$bar%foo%"]) +- : Dsexp.t list parse_result = Same (Ok [Quoted_string "$bar%foo%"]) |}] parse {|\${foo}|} [%%expect{| -- : Usexp.t list parse_result = Same (Ok [Atom (A "\\${foo}")]) +- : Dsexp.t list parse_result = Same (Ok [Atom (A "\\${foo}")]) |}] parse {|\%{foo}|} [%%expect{| -- : Usexp.t list parse_result = +- : Dsexp.t list parse_result = Different {jbuild = Ok [Atom (A "\\%{foo}")]; dune = @@ -177,17 +177,17 @@ Different parse {|\$bar%foo%|} [%%expect{| -- : Usexp.t list parse_result = Same (Ok [Atom (A "\\$bar%foo%")]) +- : Dsexp.t list parse_result = Same (Ok [Atom (A "\\$bar%foo%")]) |}] parse {|\$bar\%foo%|} [%%expect{| -- : Usexp.t list parse_result = Same (Ok [Atom (A "\\$bar\\%foo%")]) +- : Dsexp.t list parse_result = Same (Ok [Atom (A "\\$bar\\%foo%")]) |}] parse {|\$bar\%foo%{bar}|} [%%expect{| -- : Usexp.t list parse_result = +- : Dsexp.t list parse_result = Different {jbuild = Ok [Atom (A "\\$bar\\%foo%{bar}")]; dune = @@ -202,7 +202,7 @@ Different parse {|"bar%{foo}"|} [%%expect{| -- : Usexp.t list parse_result = +- : Dsexp.t list parse_result = Different {jbuild = Ok [Quoted_string "bar%{foo}"]; dune = @@ -217,7 +217,7 @@ Different parse {|"bar\%{foo}"|} [%%expect{| -- : Usexp.t list parse_result = +- : Dsexp.t list parse_result = Different {jbuild = Ok [Quoted_string "bar\\%{foo}"]; dune = Ok [Quoted_string "bar%{foo}"]} @@ -225,7 +225,7 @@ Different parse {|bar%%{foo}|} [%%expect{| -- : Usexp.t list parse_result = +- : Dsexp.t list parse_result = Different {jbuild = Ok [Atom (A "bar%%{foo}")]; dune = @@ -240,7 +240,7 @@ Different parse {|"bar%%{foo}"|} [%%expect{| -- : Usexp.t list parse_result = +- : Dsexp.t list parse_result = Different {jbuild = Ok [Quoted_string "bar%%{foo}"]; dune = @@ -255,7 +255,7 @@ Different parse {|"bar\%foo"|} [%%expect{| -- : Usexp.t list parse_result = +- : Dsexp.t list parse_result = Different {jbuild = Ok [Quoted_string "bar\\%foo"]; dune = Error "unknown escape sequence"} @@ -265,67 +265,67 @@ Different | Printing tests | +-----------------------------------------------------------------+ *) -let loc = Sexp.Loc.none -let a = Sexp.atom -let s x = Sexp.Quoted_string x -let t x = Sexp.Template { quoted = false; parts = x; loc } -let tq x = Sexp.Template { quoted = true ; parts = x; loc } -let l x = Sexp.List x -let var ?(syntax=Sexp.Template.Percent) ?payload name = - { Sexp.Template. +let loc = Loc.none +let a = Dsexp.atom +let s x = Dsexp.Quoted_string x +let t x = Dsexp.Template { quoted = false; parts = x; loc } +let tq x = Dsexp.Template { quoted = true ; parts = x; loc } +let l x = Dsexp.List x +let var ?(syntax=Dsexp.Template.Percent) ?payload name = + { Dsexp.Template. loc ; name ; payload ; syntax } -type sexp = S of Sexp.syntax * Sexp.t +type sexp = S of Dsexp.syntax * Dsexp.t -let print_sexp ppf (S (syntax, sexp)) = Sexp.pp syntax ppf sexp;; +let print_sexp ppf (S (syntax, sexp)) = Dsexp.pp syntax ppf sexp;; #install_printer print_sexp type round_trip_result = | Round_trip_success - | Did_not_round_trip of Sexp.t + | Did_not_round_trip of Dsexp.t | Did_not_parse_back of string let test syntax sexp = (S (syntax, sexp), - let s = Format.asprintf "%a" (Sexp.pp syntax) sexp in + let s = Format.asprintf "%a" (Dsexp.pp syntax) sexp in match - Sexp.parse_string s ~mode:Single ~fname:"" + Dsexp.parse_string s ~mode:Single ~fname:"" ~lexer:(match syntax with - | Jbuild -> Sexp.Lexer.jbuild_token - | Dune -> Sexp.Lexer.token) + | Jbuild -> Dsexp.Lexer.jbuild_token + | Dune -> Dsexp.Lexer.token) with | sexp' -> - let sexp' = Sexp.Ast.remove_locs sexp' in + let sexp' = Dsexp.Ast.remove_locs sexp' in if sexp = sexp' then Round_trip_success else Did_not_round_trip sexp' - | exception (Sexp.Parse_error e) -> - Did_not_parse_back (Sexp.Parse_error.message e)) + | exception (Dsexp.Parse_error e) -> + Did_not_parse_back (Dsexp.Parse_error.message e)) ;; #install_printer print_sexp [%%expect{| -val loc : Usexp.Loc.t = -val a : string -> Usexp.t = -val s : string -> Usexp.t = -val t : Usexp.Template.part list -> Usexp.t = -val tq : Usexp.Template.part list -> Usexp.t = -val l : Usexp.t list -> Usexp.t = +val loc : Loc.t = +val a : string -> Dsexp.t = +val s : string -> Dsexp.t = +val t : Dsexp.Template.part list -> Dsexp.t = +val tq : Dsexp.Template.part list -> Dsexp.t = +val l : Dsexp.t list -> Dsexp.t = val var : - ?syntax:Usexp.Template.var_syntax -> - ?payload:string -> string -> Usexp.Template.var = -type sexp = S of Usexp.syntax * Usexp.t + ?syntax:Dsexp.Template.var_syntax -> + ?payload:string -> string -> Dsexp.Template.var = +type sexp = S of Dsexp.syntax * Dsexp.t val print_sexp : Format.formatter -> sexp -> unit = type round_trip_result = Round_trip_success - | Did_not_round_trip of Usexp.t + | Did_not_round_trip of Dsexp.t | Did_not_parse_back of string -val test : Usexp.syntax -> Usexp.t -> sexp * round_trip_result = +val test : Dsexp.syntax -> Dsexp.t -> sexp * round_trip_result = |}] test Dune (a "toto") diff --git a/test/unit-tests/sexp_tests.ml b/test/unit-tests/sexp_tests.ml index d93ed5e9..50746748 100644 --- a/test/unit-tests/sexp_tests.ml +++ b/test/unit-tests/sexp_tests.ml @@ -2,17 +2,17 @@ open! Stdune let () = Printexc.record_backtrace true -(* Test that all strings of length <= 3 such that [Usexp.Atom.is_valid +(* Test that all strings of length <= 3 such that [Dsexp.Atom.is_valid s] are recignized as atoms by the parser *) -let string_of_syntax (x : Usexp.syntax) = +let string_of_syntax (x : Dsexp.syntax) = match x with | Dune -> "dune" | Jbuild -> "jbuild" let () = - [ Usexp.Dune, Usexp.Lexer.token, (fun s -> Usexp.Atom.is_valid s Dune) - ; Jbuild, Usexp.Lexer.jbuild_token, (fun s -> Usexp.Atom.is_valid s Jbuild) + [ Dsexp.Dune, Dsexp.Lexer.token, (fun s -> Dsexp.Atom.is_valid s Dune) + ; Jbuild, Dsexp.Lexer.jbuild_token, (fun s -> Dsexp.Atom.is_valid s Jbuild) ] |> List.iter ~f:(fun (syntax, lexer, validator) -> for len = 0 to 3 do @@ -23,23 +23,23 @@ let () = if len > 2 then Bytes.set s 2 (Char.chr ((i lsr 8) land 0xff)); let s = Bytes.unsafe_to_string s in let parser_recognizes_as_atom = - match Usexp.parse_string ~lexer ~fname:"" ~mode:Single s with + match Dsexp.parse_string ~lexer ~fname:"" ~mode:Single s with | exception _ -> false | Atom (_, A s') -> s = s' | _ -> false in let printed_as_atom = - match Usexp.atom_or_quoted_string s with + match Dsexp.atom_or_quoted_string s with | Atom _ -> true | _ -> false in - let valid_dune_atom = validator (Usexp.Atom.of_string s) in + let valid_dune_atom = validator (Dsexp.Atom.of_string s) in if valid_dune_atom <> parser_recognizes_as_atom then begin Printf.eprintf - "Usexp.Atom.is_valid error:\n\ + "Dsexp.Atom.is_valid error:\n\ - syntax = %s\n\ - s = %S\n\ - - Usexp.Atom.is_valid s = %B\n\ + - Dsexp.Atom.is_valid s = %B\n\ - parser_recognizes_as_atom = %B\n" (string_of_syntax syntax) s valid_dune_atom parser_recognizes_as_atom; @@ -47,7 +47,7 @@ let () = end; if printed_as_atom && not parser_recognizes_as_atom then begin Printf.eprintf - "Usexp.Atom.atom_or_quoted_string error:\n\ + "Dsexp.Atom.atom_or_quoted_string error:\n\ - syntax = %s\n\ - s = %S\n\ - printed_as_atom = %B\n\ diff --git a/test/unit-tests/tests.mlt b/test/unit-tests/tests.mlt index 2a913255..4775b665 100644 --- a/test/unit-tests/tests.mlt +++ b/test/unit-tests/tests.mlt @@ -104,7 +104,7 @@ val conf : Findlib.Config.t = } |}] -let env_pp fmt env = Sexp.pp Dune fmt (Env.sexp_of_t env);; +let env_pp fmt env = Sexp.pp fmt (Env.to_sexp env);; #install_printer env_pp;; [%%expect{|