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

Make Atom.t private and consequences (#524)

This commit is contained in:
Christophe Troestler 2018-02-25 00:33:26 +01:00 committed by Jérémie Dimino
parent 8a81c79531
commit fbafb3d47a
23 changed files with 299 additions and 242 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
bin/main.ml
View File

@ -872,7 +872,8 @@ let rules =
; "targets", paths rule.targets ] ; "targets", paths rule.targets ]
; (match rule.context with ; (match rule.context with
| None -> [] | None -> []
| Some c -> ["context", Atom c.name]) | Some c -> ["context",
Sexp.atom_or_quoted_string c.name])
; [ "action" , sexp_of_action rule.action ] ; [ "action" , sexp_of_action rule.action ]
]) ])
in in

58
src/action.ml
View File

@ -69,38 +69,45 @@ struct
let rec sexp_of_t : _ -> Sexp.t = let rec sexp_of_t : _ -> Sexp.t =
let path = Path.sexp_of_t and string = String.sexp_of_t in let path = Path.sexp_of_t and string = String.sexp_of_t in
function function
| Run (a, xs) -> List (Atom "run" :: Program.sexp_of_t a :: List.map xs ~f:string) | Run (a, xs) -> List (Sexp.unsafe_atom_of_string "run"
| Chdir (a, r) -> List [Atom "chdir" ; path a ; sexp_of_t r] :: Program.sexp_of_t a :: List.map xs ~f:string)
| Setenv (k, v, r) -> List [Atom "setenv" ; string k ; string v ; sexp_of_t r] | 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]
| Redirect (outputs, fn, r) -> | Redirect (outputs, fn, r) ->
List [ Atom (sprintf "with-%s-to" (Outputs.to_string outputs)) List [ Sexp.atom (sprintf "with-%s-to" (Outputs.to_string outputs))
; path fn ; path fn
; sexp_of_t r ; sexp_of_t r
] ]
| Ignore (outputs, r) -> | Ignore (outputs, r) ->
List [ Atom (sprintf "ignore-%s" (Outputs.to_string outputs)) List [ Sexp.atom (sprintf "ignore-%s" (Outputs.to_string outputs))
; sexp_of_t r ; sexp_of_t r
] ]
| Progn l -> List (Atom "progn" :: List.map l ~f:sexp_of_t) | Progn l -> List (Sexp.unsafe_atom_of_string "progn"
| Echo x -> List [Atom "echo"; string x] :: List.map l ~f:sexp_of_t)
| Cat x -> List [Atom "cat"; path x] | Echo x -> List [Sexp.unsafe_atom_of_string "echo"; string x]
| Cat x -> List [Sexp.unsafe_atom_of_string "cat"; path x]
| Copy (x, y) -> | Copy (x, y) ->
List [Atom "copy"; path x; path y] List [Sexp.unsafe_atom_of_string "copy"; path x; path y]
| Symlink (x, y) -> | Symlink (x, y) ->
List [Atom "symlink"; path x; path y] List [Sexp.unsafe_atom_of_string "symlink"; path x; path y]
| Copy_and_add_line_directive (x, y) -> | Copy_and_add_line_directive (x, y) ->
List [Atom "copy#"; path x; path y] List [Sexp.unsafe_atom_of_string "copy#"; path x; path y]
| System x -> List [Atom "system"; string x] | System x -> List [Sexp.unsafe_atom_of_string "system"; string x]
| Bash x -> List [Atom "bash"; string x] | Bash x -> List [Sexp.unsafe_atom_of_string "bash"; string x]
| Write_file (x, y) -> List [Atom "write-file"; path x; string y] | Write_file (x, y) -> List [Sexp.unsafe_atom_of_string "write-file";
| Rename (x, y) -> List [Atom "rename"; path x; path y] path x; string y]
| Remove_tree x -> List [Atom "remove-tree"; path x] | Rename (x, y) -> List [Sexp.unsafe_atom_of_string "rename";
| Mkdir x -> List [Atom "mkdir"; path x] path x; path y]
| Digest_files paths -> List [Atom "digest-files"; List (List.map paths ~f:path)] | 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 (List.map paths ~f:path)]
| Diff { optional = false; file1; file2 } -> | Diff { optional = false; file1; file2 } ->
List [Atom "diff"; path file1; path file2] List [Sexp.unsafe_atom_of_string "diff"; path file1; path file2]
| Diff { optional = true; file1; file2 } -> | Diff { optional = true; file1; file2 } ->
List [Atom "diff?"; path file1; path file2] List [Sexp.unsafe_atom_of_string "diff?"; path file1; path file2]
let run prog args = Run (prog, args) let run prog args = Run (prog, args)
let chdir path t = Chdir (path, t) let chdir path t = Chdir (path, t)
@ -180,7 +187,7 @@ module Prog = struct
let sexp_of_t = function let sexp_of_t = function
| Ok s -> Path.sexp_of_t s | Ok s -> Path.sexp_of_t s
| Error (e : Not_found.t) -> Sexp.To_sexp.atom e.program | Error (e : Not_found.t) -> Sexp.To_sexp.string e.program
end end
module type Ast = Action_intf.Ast module type Ast = Action_intf.Ast
@ -192,7 +199,7 @@ module rec Ast : Ast = Ast
module String_with_sexp = struct module String_with_sexp = struct
type t = string type t = string
let t = Sexp.Of_sexp.string let t = Sexp.Of_sexp.string
let sexp_of_t = Sexp.To_sexp.atom let sexp_of_t = Sexp.To_sexp.string
end end
include Make_ast include Make_ast
@ -345,7 +352,7 @@ module Unexpanded = struct
Loc.fail loc Loc.fail loc
"(mkdir ...) is not supported for paths outside of the workspace:\n\ "(mkdir ...) is not supported for paths outside of the workspace:\n\
\ %a\n" \ %a\n"
Sexp.pp (List [Atom "mkdir"; Path.sexp_of_t path]) Sexp.pp (List [Sexp.unsafe_atom_of_string "mkdir"; Path.sexp_of_t path])
module Partial = struct module Partial = struct
module Program = Unresolved.Program module Program = Unresolved.Program
@ -594,7 +601,7 @@ module Promotion = struct
} }
let t = function let t = function
| Sexp.Ast.List (_, [src; Atom (_, "as"); dst]) -> | Sexp.Ast.List (_, [src; Atom (_, A "as"); dst]) ->
{ src = Path.t src { src = Path.t src
; dst = Path.t dst ; dst = Path.t dst
} }
@ -602,7 +609,8 @@ module Promotion = struct
Sexp.Of_sexp.of_sexp_errorf sexp "(<file> as <file>) expected" Sexp.Of_sexp.of_sexp_errorf sexp "(<file> as <file>) expected"
let sexp_of_t { src; dst } = let sexp_of_t { src; dst } =
Sexp.List [Path.sexp_of_t src; Atom "as"; Path.sexp_of_t dst] Sexp.List [Path.sexp_of_t src; Sexp.unsafe_atom_of_string "as";
Path.sexp_of_t dst]
let db : t list ref = ref [] let db : t list ref = ref []

3
src/build_system.ml
View File

@ -1086,7 +1086,8 @@ module Trace = struct
Pmap.add acc ~key ~data) Pmap.add acc ~key ~data)
|> Path.Map.bindings |> Path.Map.bindings
|> List.map ~f:(fun (path, hash) -> |> List.map ~f:(fun (path, hash) ->
Sexp.List [ Atom (Path.to_string path); Atom (Digest.to_hex hash) ])) Sexp.List [ Path.sexp_of_t path;
Atom (Sexp.Atom.of_digest hash) ]))
in in
if Sys.file_exists "_build" then if Sys.file_exists "_build" then
Io.write_file file (Sexp.to_string sexp) Io.write_file file (Sexp.to_string sexp)

16
src/context.ml
View File

@ -11,10 +11,10 @@ module Kind = struct
type t = Default | Opam of Opam.t type t = Default | Opam of Opam.t
let sexp_of_t : t -> Sexp.t = function let sexp_of_t : t -> Sexp.t = function
| Default -> Atom "default" | Default -> Sexp.unsafe_atom_of_string "default"
| Opam o -> | Opam o ->
Sexp.To_sexp.(record [ "root" , atom o.root Sexp.To_sexp.(record [ "root" , string o.root
; "switch", atom o.switch ; "switch", string o.switch
]) ])
end end
@ -92,10 +92,10 @@ let sexp_of_t t =
let open Sexp.To_sexp in let open Sexp.To_sexp in
let path = Path.sexp_of_t in let path = Path.sexp_of_t in
record record
[ "name", atom t.name [ "name", string t.name
; "kind", Kind.sexp_of_t t.kind ; "kind", Kind.sexp_of_t t.kind
; "merlin", bool t.merlin ; "merlin", bool t.merlin
; "for_host", option atom (Option.map t.for_host ~f:(fun t -> t.name)) ; "for_host", option string (Option.map t.for_host ~f:(fun t -> t.name))
; "build_dir", path t.build_dir ; "build_dir", path t.build_dir
; "toplevel_path", option path t.toplevel_path ; "toplevel_path", option path t.toplevel_path
; "ocaml_bin", path t.ocaml_bin ; "ocaml_bin", path t.ocaml_bin
@ -104,13 +104,13 @@ let sexp_of_t t =
; "ocamlopt", option path t.ocamlopt ; "ocamlopt", option path t.ocamlopt
; "ocamldep", path t.ocamldep ; "ocamldep", path t.ocamldep
; "ocamlmklib", path t.ocamlmklib ; "ocamlmklib", path t.ocamlmklib
; "env", list (pair atom atom) (Env_var_map.bindings t.env_extra) ; "env", list (pair string string) (Env_var_map.bindings t.env_extra)
; "findlib_path", list path (Findlib.path t.findlib) ; "findlib_path", list path (Findlib.path t.findlib)
; "arch_sixtyfour", bool t.arch_sixtyfour ; "arch_sixtyfour", bool t.arch_sixtyfour
; "natdynlink_supported", bool t.natdynlink_supported ; "natdynlink_supported", bool t.natdynlink_supported
; "opam_vars", atom_hashtbl atom t.opam_var_cache ; "opam_vars", string_hashtbl string t.opam_var_cache
; "ocamlc_config", Ocamlc_config.sexp_of_t t.ocamlc_config ; "ocamlc_config", Ocamlc_config.sexp_of_t t.ocamlc_config
; "which", atom_hashtbl (option path) t.which_cache ; "which", string_hashtbl (option path) t.which_cache
] ]
let compare a b = compare a.name b.name let compare a b = compare a.name b.name

8
src/gen_rules.ml
View File

@ -101,8 +101,10 @@ module Gen(P : Params) = struct
\n %s\ \n %s\
\n\ \n\
\nThis will become an error in the future." \nThis will become an error in the future."
(Sexp.to_string (List [ Atom "modules_without_implementation" (let tag = Sexp.unsafe_atom_of_string
; Sexp.To_sexp.(list atom) should_be_listed "modules_without_implementation" in
Sexp.to_string (List [ tag
; Sexp.To_sexp.(list string) should_be_listed
])) ]))
| Some loc -> | Some loc ->
Loc.warn loc Loc.warn loc
@ -804,7 +806,7 @@ module Gen(P : Params) = struct
let stamp = let stamp =
let module S = Sexp.To_sexp in let module S = Sexp.To_sexp in
Sexp.List Sexp.List
[ Atom "user-alias" [ Sexp.unsafe_atom_of_string "user-alias"
; S.list Jbuild.Dep_conf.sexp_of_t alias_conf.deps ; S.list Jbuild.Dep_conf.sexp_of_t alias_conf.deps
; S.option Action.Unexpanded.sexp_of_t alias_conf.action ; S.option Action.Unexpanded.sexp_of_t alias_conf.action
] ]

33
src/jbuild.ml
View File

@ -205,7 +205,7 @@ module Pp_or_flags = struct
PP (Pp.of_string s) PP (Pp.of_string s)
let t = function let t = function
| Atom (_, s) | Quoted_string (_, s) -> of_string s | Atom (_, A s) | Quoted_string (_, s) -> of_string s
| List (_, l) -> Flags (List.map l ~f:string) | List (_, l) -> Flags (List.map l ~f:string)
let split l = let split l =
@ -246,15 +246,18 @@ module Dep_conf = struct
open Sexp open Sexp
let sexp_of_t = function let sexp_of_t = function
| File t -> | File t ->
List [Atom "file" ; String_with_vars.sexp_of_t t] List [Sexp.unsafe_atom_of_string "file" ; String_with_vars.sexp_of_t t]
| Alias t -> | Alias t ->
List [Atom "alias" ; String_with_vars.sexp_of_t t] List [Sexp.unsafe_atom_of_string "alias" ; String_with_vars.sexp_of_t t]
| Alias_rec t -> | Alias_rec t ->
List [Atom "alias_rec" ; String_with_vars.sexp_of_t t] List [Sexp.unsafe_atom_of_string "alias_rec" ;
String_with_vars.sexp_of_t t]
| Glob_files t -> | Glob_files t ->
List [Atom "glob_files" ; String_with_vars.sexp_of_t t] List [Sexp.unsafe_atom_of_string "glob_files" ;
String_with_vars.sexp_of_t t]
| Files_recursively_in t -> | Files_recursively_in t ->
List [Atom "files_recursively_in" ; String_with_vars.sexp_of_t t] List [Sexp.unsafe_atom_of_string "files_recursively_in" ;
String_with_vars.sexp_of_t t]
end end
module Preprocess = struct module Preprocess = struct
@ -283,7 +286,7 @@ module Per_module = struct
let t ~default a sexp = let t ~default a sexp =
match sexp with match sexp with
| List (_, Atom (_, "per_module") :: rest) -> begin | List (_, Atom (_, A "per_module") :: rest) -> begin
List.map rest ~f:(fun sexp -> List.map rest ~f:(fun sexp ->
let pp, names = pair a module_names sexp in let pp, names = pair a module_names sexp in
(String_set.elements names, pp)) (String_set.elements names, pp))
@ -364,7 +367,7 @@ module Lib_dep = struct
let choice = function let choice = function
| List (_, l) as sexp -> | List (_, l) as sexp ->
let rec loop required forbidden = function let rec loop required forbidden = function
| [Atom (_, "->"); fsexp] -> | [Atom (_, A "->"); fsexp] ->
let common = String_set.inter required forbidden in let common = String_set.inter required forbidden in
if not (String_set.is_empty common) then if not (String_set.is_empty common) then
of_sexp_errorf sexp of_sexp_errorf sexp
@ -374,10 +377,10 @@ module Lib_dep = struct
; forbidden ; forbidden
; file = file fsexp ; file = file fsexp
} }
| Atom (_, "->") :: _ | Atom (_, A "->") :: _
| List _ :: _ | [] -> | List _ :: _ | [] ->
of_sexp_error sexp "(<[!]libraries>... -> <file>) expected" of_sexp_error sexp "(<[!]libraries>... -> <file>) expected"
| (Atom (_, s) | Quoted_string (_, s)) :: l -> | (Atom (_, A s) | Quoted_string (_, s)) :: l ->
let len = String.length s in let len = String.length s in
if len > 0 && s.[0] = '!' then if len > 0 && s.[0] = '!' then
let s = String.sub s ~pos:1 ~len:(len - 1) in let s = String.sub s ~pos:1 ~len:(len - 1) in
@ -389,9 +392,9 @@ module Lib_dep = struct
| sexp -> of_sexp_error sexp "(<library-name> <code>) expected" | sexp -> of_sexp_error sexp "(<library-name> <code>) expected"
let t = function let t = function
| Atom (_, s) -> | Atom (_, A s) ->
Direct s Direct s
| List (loc, Atom (_, "select") :: m :: Atom (_, "from") :: libs) -> | List (loc, Atom (_, A "select") :: m :: Atom (_, A "from") :: libs) ->
Select { result_fn = file m Select { result_fn = file m
; choices = List.map libs ~f:choice ; choices = List.map libs ~f:choice
; loc ; loc
@ -641,8 +644,8 @@ module Install_conf = struct
let file sexp = let file sexp =
match sexp with match sexp with
| Atom (_, src) -> { src; dst = None } | Atom (_, A src) -> { src; dst = None }
| List (_, [Atom (_, src); Atom (_, "as"); Atom (_, dst)]) -> | List (_, [Atom (_, A src); Atom (_, A "as"); Atom (_, A dst)]) ->
{ src; dst = Some dst } { src; dst = Some dst }
| _ -> | _ ->
of_sexp_error sexp of_sexp_error sexp
@ -1064,7 +1067,7 @@ module Stanzas = struct
and parse ~default_version ~file ~include_stack pkgs sexps = and parse ~default_version ~file ~include_stack pkgs sexps =
let versions, sexps = let versions, sexps =
List.partition_map sexps ~f:(function List.partition_map sexps ~f:(function
| List (loc, [Atom (_, "jbuild_version"); ver]) -> | List (loc, [Atom (_, A "jbuild_version"); ver]) ->
Inl (Jbuild_version.t ver, loc) Inl (Jbuild_version.t ver, loc)
| sexp -> Inr sexp) | sexp -> Inr sexp)
in in

15
src/lib.ml
View File

@ -452,19 +452,22 @@ and resolve_name db name ~stack =
in in
(* Add [init] to the table, to detect loops *) (* Add [init] to the table, to detect loops *)
Option.iter (Hashtbl.find db.table name) ~f:(fun x -> Option.iter (Hashtbl.find db.table name) ~f:(fun x ->
let to_sexp = Sexp.To_sexp.(pair Path.sexp_of_t atom) in let to_sexp = Sexp.To_sexp.(pair Path.sexp_of_t string) in
let sexp = let sexp =
match x with match x with
| Initializing x -> | Initializing x ->
Sexp.List [Atom "Initializing"; Path.sexp_of_t x.path] Sexp.List [Sexp.unsafe_atom_of_string "Initializing";
| Done (Ok t) -> List [Atom "Ok"; Path.sexp_of_t t.src_dir] Path.sexp_of_t x.path]
| Done (Error Not_found) -> Atom "Not_found" | Done (Ok t) -> List [Sexp.unsafe_atom_of_string "Ok";
Path.sexp_of_t t.src_dir]
| Done (Error Not_found) -> Sexp.unsafe_atom_of_string "Not_found"
| Done (Error (Hidden { info; reason; _ })) -> | Done (Error (Hidden { info; reason; _ })) ->
List [Atom "Hidden"; Path.sexp_of_t info.src_dir; Atom reason] List [Sexp.unsafe_atom_of_string "Hidden";
Path.sexp_of_t info.src_dir; Sexp.atom reason]
in in
Sexp.code_error Sexp.code_error
"Lib_db.DB: resolver returned name that's already in the table" "Lib_db.DB: resolver returned name that's already in the table"
[ "name" , Atom name [ "name" , Sexp.atom name
; "returned_lib" , to_sexp (info.src_dir, name) ; "returned_lib" , to_sexp (info.src_dir, name)
; "conflicting_with", sexp ; "conflicting_with", sexp
]); ]);

2
src/ocamlc_config.ml
View File

@ -11,7 +11,7 @@ let ocamlc_config_cmd ocamlc =
let sexp_of_t t = let sexp_of_t t =
let open Sexp.To_sexp in let open Sexp.To_sexp in
atom_map atom t.bindings string_map Sexp.atom_or_quoted_string t.bindings
let read ~ocamlc ~env = let read ~ocamlc ~env =
Process.run_capture_lines ~env Strict (Path.to_string ocamlc) ["-config"] Process.run_capture_lines ~env Strict (Path.to_string ocamlc) ["-config"]

4
src/ocamldep.ml
View File

@ -15,8 +15,8 @@ module Dep_graph = struct
| None -> | None ->
Sexp.code_error "Ocamldep.Dep_graph.deps_of" Sexp.code_error "Ocamldep.Dep_graph.deps_of"
[ "dir", Path.sexp_of_t t.dir [ "dir", Path.sexp_of_t t.dir
; "modules", Sexp.To_sexp.(list atom) (String_map.keys t.per_module) ; "modules", Sexp.To_sexp.(list string) (String_map.keys t.per_module)
; "module", Atom m.name ; "module", Sexp.atom m.name
] ]
module Dep_closure = module Dep_closure =

15
src/ordered_set_lang.ml
View File

@ -24,16 +24,17 @@ let loc t = t.loc
let parse_general sexp ~f = let parse_general sexp ~f =
let rec of_sexp : Sexp.Ast.t -> _ = function let rec of_sexp : Sexp.Ast.t -> _ = function
| Atom (loc, "\\") -> Loc.fail loc "unexpected \\" | Atom (loc, A "\\") -> Loc.fail loc "unexpected \\"
| (Atom (_, "") | Quoted_string (_, _)) as t -> Ast.Element (f t) | (Atom (_, A "") | Quoted_string (_, _)) as t -> Ast.Element (f t)
| Atom (loc, s) as t -> | Atom (loc, A s) as t ->
if s.[0] = ':' then if s.[0] = ':' then
Special (loc, String.sub s ~pos:1 ~len:(String.length s - 1)) Special (loc, String.sub s ~pos:1 ~len:(String.length s - 1))
else else
Element (f t) Element (f t)
| List (_, sexps) -> of_sexps [] sexps | List (_, sexps) -> of_sexps [] sexps
and of_sexps acc = function and of_sexps acc = function
| Atom (_, "\\") :: sexps -> Diff (Union (List.rev acc), of_sexps [] sexps) | Atom (_, A "\\") :: sexps ->
Diff (Union (List.rev acc), of_sexps [] sexps)
| elt :: sexps -> | elt :: sexps ->
of_sexps (of_sexp elt :: acc) sexps of_sexps (of_sexp elt :: acc) sexps
| [] -> Union (List.rev acc) | [] -> Union (List.rev acc)
@ -43,7 +44,7 @@ let parse_general sexp ~f =
let t sexp : t = let t sexp : t =
let ast = let ast =
parse_general sexp ~f:(function parse_general sexp ~f:(function
| Atom (loc, s) | Quoted_string (loc, s) -> (loc, s) | Atom (loc, A s) | Quoted_string (loc, s) -> (loc, s)
| List _ -> assert false) | List _ -> assert false)
in in
{ ast { ast
@ -194,8 +195,8 @@ module Unexpanded = struct
| None -> | None ->
Sexp.code_error Sexp.code_error
"Ordered_set_lang.Unexpanded.expand" "Ordered_set_lang.Unexpanded.expand"
[ "included-file", Atom fn [ "included-file", Quoted_string fn
; "files", Sexp.To_sexp.(list atom) (String_map.keys files_contents) ; "files", Sexp.To_sexp.(list string) (String_map.keys files_contents)
] ]
in in
parse_general sexp ~f:(fun sexp -> parse_general sexp ~f:(fun sexp ->

11
src/path.ml
View File

@ -222,7 +222,7 @@ let compare = String.compare
module Set = struct module Set = struct
include String_set include String_set
let sexp_of_t t = Sexp.To_sexp.(list atom) (String_set.elements t) let sexp_of_t t = Sexp.To_sexp.(list string) (String_set.elements t)
let of_string_set = map let of_string_set = map
end end
@ -270,7 +270,7 @@ let of_string ?error_loc s =
s s
let t sexp = of_string (Sexp.Of_sexp.string sexp) ~error_loc:(Sexp.Ast.loc sexp) let t sexp = of_string (Sexp.Of_sexp.string sexp) ~error_loc:(Sexp.Ast.loc sexp)
let sexp_of_t t = Sexp.Atom (to_string t) let sexp_of_t t = Sexp.atom_or_quoted_string (to_string t)
let absolute fn = let absolute fn =
if is_local fn then if is_local fn then
@ -424,7 +424,8 @@ let explode_exn t =
else if is_local t then else if is_local t then
String.split t ~on:'/' String.split t ~on:'/'
else else
Sexp.code_error "Path.explode_exn" ["path", Atom t] Sexp.code_error "Path.explode_exn"
["path", Sexp.atom_or_quoted_string t]
let exists t = Sys.file_exists (to_string t) let exists t = Sys.file_exists (to_string t)
let readdir t = Sys.readdir (to_string t) |> Array.to_list let readdir t = Sys.readdir (to_string t) |> Array.to_list
@ -457,8 +458,8 @@ let insert_after_build_dir_exn =
let error a b = let error a b =
Sexp.code_error Sexp.code_error
"Path.insert_after_build_dir_exn" "Path.insert_after_build_dir_exn"
[ "path" , Atom a [ "path" , Sexp.unsafe_atom_of_string a
; "insert", Atom b ; "insert", Sexp.unsafe_atom_of_string b
] ]
in in
fun a b -> fun a b ->

8
src/scope.ml
View File

@ -29,7 +29,7 @@ module DB = struct
if Path.is_root d || not (Path.is_local d) then if Path.is_root d || not (Path.is_local d) then
Sexp.code_error "Scope.DB.find_by_dir got an invalid path" Sexp.code_error "Scope.DB.find_by_dir got an invalid path"
[ "dir" , Path.sexp_of_t dir [ "dir" , Path.sexp_of_t dir
; "context", Sexp.To_sexp.atom t.context ; "context", Sexp.To_sexp.string t.context
]; ];
let scope = loop (Path.parent d) in let scope = loop (Path.parent d) in
Hashtbl.add t.by_dir ~key:d ~data:scope; Hashtbl.add t.by_dir ~key:d ~data:scope;
@ -42,8 +42,8 @@ module DB = struct
| Some x -> x | Some x -> x
| None -> | None ->
Sexp.code_error "Scope.DB.find_by_name" Sexp.code_error "Scope.DB.find_by_name"
[ "name" , Sexp.To_sexp.(option atom) name [ "name" , Sexp.To_sexp.(option string) name
; "context", Sexp.To_sexp.atom t.context ; "context", Sexp.To_sexp.string t.context
] ]
let create ~scopes ~context ~installed_libs internal_libs = let create ~scopes ~context ~installed_libs internal_libs =
@ -55,7 +55,7 @@ module DB = struct
| Ok x -> x | Ok x -> x
| Error (_name, scope1, scope2) -> | Error (_name, scope1, scope2) ->
let to_sexp (scope : Jbuild.Scope_info.t) = let to_sexp (scope : Jbuild.Scope_info.t) =
Sexp.To_sexp.(pair (option atom) Path.sexp_of_t) Sexp.To_sexp.(pair (option string) Path.sexp_of_t)
(scope.name, scope.root) (scope.name, scope.root)
in in
Sexp.code_error "Scope.DB.create got two scopes with the same name" Sexp.code_error "Scope.DB.create got two scopes with the same name"

75
src/sexp.ml
View File

@ -5,9 +5,9 @@ include (Usexp : module type of struct include Usexp end
let code_error message vars = let code_error message vars =
code_errorf "%a" pp code_errorf "%a" pp
(List (Atom message (List (Usexp.atom_or_quoted_string message
:: List.map vars ~f:(fun (name, value) -> :: List.map vars ~f:(fun (name, value) ->
List [Atom name; value]))) List [Usexp.atom_or_quoted_string name; value])))
let buf_len = 65_536 let buf_len = 65_536
@ -68,8 +68,7 @@ let load_many_or_ocaml_script fname =
module type Combinators = sig module type Combinators = sig
type 'a t type 'a t
val unit : unit t val unit : unit t
val atom : string t val string : string t
val quoted_string : string t
val int : int t val int : int t
val float : float t val float : float t
val bool : bool t val bool : bool t
@ -78,19 +77,18 @@ module type Combinators = sig
val list : 'a t -> 'a list t val list : 'a t -> 'a list t
val array : 'a t -> 'a array t val array : 'a t -> 'a array t
val option : 'a t -> 'a option t val option : 'a t -> 'a option t
val atom_set : String_set.t t val string_set : String_set.t t
val atom_map : 'a t -> 'a String_map.t t val string_map : 'a t -> 'a String_map.t t
val atom_hashtbl : 'a t -> (string, 'a) Hashtbl.t t val string_hashtbl : 'a t -> (string, 'a) Hashtbl.t t
end end
module To_sexp = struct module To_sexp = struct
type nonrec 'a t = 'a -> t type nonrec 'a t = 'a -> t
let unit () = List [] let unit () = List []
let atom a = Atom a let string = Usexp.atom_or_quoted_string
let quoted_string s = Quoted_string s let int n = Atom (Atom.of_int n)
let int n = Atom (string_of_int n) let float f = Atom (Atom.of_float f)
let float f = Atom (string_of_float f) let bool b = Atom (Atom.of_bool b)
let bool b = Atom (string_of_bool b)
let pair fa fb (a, b) = List [fa a; fb 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 triple fa fb fc (a, b, c) = List [fa a; fb b; fc c]
let list f l = List (List.map l ~f) let list f l = List (List.map l ~f)
@ -98,19 +96,19 @@ module To_sexp = struct
let option f = function let option f = function
| None -> List [] | None -> List []
| Some x -> List [f x] | Some x -> List [f x]
let atom_set set = list atom (String_set.elements set) let string_set set = list atom (String_set.elements set)
let atom_map f map = list (pair atom f) (String_map.bindings map) let string_map f map = list (pair atom f) (String_map.bindings map)
let record l = let record l =
List (List.map l ~f:(fun (n, v) -> List [Atom n; v])) List (List.map l ~f:(fun (n, v) -> List [Atom(Atom.of_string n); v]))
let atom_hashtbl f h = let string_hashtbl f h =
atom_map f string_map f
(Hashtbl.fold h ~init:String_map.empty ~f:(fun ~key ~data acc -> (Hashtbl.fold h ~init:String_map.empty ~f:(fun ~key ~data acc ->
String_map.add acc ~key ~data)) String_map.add acc ~key ~data))
end end
module Of_sexp = struct module Of_sexp = struct
type ast = Ast.t = type ast = Ast.t =
| Atom of Loc.t * string | Atom of Loc.t * Atom.t
| Quoted_string of Loc.t * string | Quoted_string of Loc.t * string
| List of Loc.t * ast list | List of Loc.t * ast list
@ -126,33 +124,24 @@ module Of_sexp = struct
| List (_, []) -> () | List (_, []) -> ()
| sexp -> of_sexp_error sexp "() expected" | sexp -> of_sexp_error sexp "() expected"
let atom = function
| Atom (_, s) -> s
| (Quoted_string _ | List _) as sexp ->
of_sexp_error sexp "Atom expected"
let quoted_string = function
| Quoted_string (_, s) -> s
| (Atom _ | List _) as sexp -> of_sexp_error sexp "Quoted_string expected"
let string = function let string = function
| Atom (_, s) -> s | Atom (_, A s) -> s
| Quoted_string (_, s) -> s | Quoted_string (_, s) -> s
| List _ as sexp -> of_sexp_error sexp "Atom or quoted string expected" | List _ as sexp -> of_sexp_error sexp "Atom or quoted string expected"
let int sexp = match sexp with let int sexp = match sexp with
| Atom (_, s) -> (try int_of_string s | Atom (_, A s) -> (try int_of_string s
with _ -> of_sexp_error sexp "Integer expected") with _ -> of_sexp_error sexp "Integer expected")
| _ -> of_sexp_error sexp "Integer expected" | _ -> of_sexp_error sexp "Integer expected"
let float sexp = match sexp with let float sexp = match sexp with
| Atom (_, s) -> (try float_of_string s | Atom (_, A s) -> (try float_of_string s
with _ -> of_sexp_error sexp "Float expected") with _ -> of_sexp_error sexp "Float expected")
| _ -> of_sexp_error sexp "Float expected" | _ -> of_sexp_error sexp "Float expected"
let bool = function let bool = function
| Atom (_, "true") -> true | Atom (_, A "true") -> true
| Atom (_, "false") -> false | Atom (_, A "false") -> false
| sexp -> of_sexp_error sexp "'true' or 'false' expected" | sexp -> of_sexp_error sexp "'true' or 'false' expected"
let pair fa fb = function let pair fa fb = function
@ -174,15 +163,15 @@ module Of_sexp = struct
| List (_, [x]) -> Some (f x) | List (_, [x]) -> Some (f x)
| sexp -> of_sexp_error sexp "S-expression of the form () or (_) expected" | sexp -> of_sexp_error sexp "S-expression of the form () or (_) expected"
let atom_set sexp = String_set.of_list (list string sexp) let string_set sexp = String_set.of_list (list string sexp)
let atom_map f sexp = let string_map f sexp =
match String_map.of_alist (list (pair string f) sexp) with match String_map.of_alist (list (pair string f) sexp) with
| Ok x -> x | Ok x -> x
| Error (key, _v1, _v2) -> | Error (key, _v1, _v2) ->
of_sexp_error sexp (sprintf "key %S present multiple times" key) of_sexp_error sexp (sprintf "key %S present multiple times" key)
let atom_hashtbl f sexp = let string_hashtbl f sexp =
let map = atom_map f sexp in let map = string_map f sexp in
let tbl = Hashtbl.create (String_map.cardinal map + 32) in let tbl = Hashtbl.create (String_map.cardinal map + 32) in
String_map.iter map ~f:(fun ~key ~data -> String_map.iter map ~f:(fun ~key ~data ->
Hashtbl.add tbl ~key ~data); Hashtbl.add tbl ~key ~data);
@ -303,11 +292,11 @@ module Of_sexp = struct
let unparsed = let unparsed =
List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp -> List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp ->
match sexp with match sexp with
| List (_, [Atom (_, name)]) -> | List (_, [Atom (_, A name)]) ->
Name_map.add acc ~key:name ~data:{ value = None; entry = sexp } Name_map.add acc ~key:name ~data:{ value = None; entry = sexp }
| List (_, [name_sexp; value]) -> begin | List (_, [name_sexp; value]) -> begin
match name_sexp with match name_sexp with
| Atom (_, name) -> | Atom (_, A name) ->
Name_map.add acc ~key:name ~data:{ value = Some value; Name_map.add acc ~key:name ~data:{ value = Some value;
entry = sexp } entry = sexp }
| List _ | Quoted_string _ -> | List _ | Quoted_string _ ->
@ -416,7 +405,7 @@ module Of_sexp = struct
let sum cstrs sexp = let sum cstrs sexp =
match sexp with match sexp with
| Atom (loc, s) -> begin | Atom (loc, A s) -> begin
match find_cstr cstrs sexp s with match find_cstr cstrs sexp s with
| C.Tuple t -> Constructor_args_spec.convert t.args t.rest sexp [] (t.make loc) | C.Tuple t -> Constructor_args_spec.convert t.args t.rest sexp [] (t.make loc)
| C.Record _ -> of_sexp_error sexp "'%s' expect arguments" | C.Record _ -> of_sexp_error sexp "'%s' expect arguments"
@ -426,7 +415,7 @@ module Of_sexp = struct
| List (loc, name_sexp :: args) -> | List (loc, name_sexp :: args) ->
match name_sexp with match name_sexp with
| Quoted_string _ | List _ -> of_sexp_error name_sexp "Atom expected" | Quoted_string _ | List _ -> of_sexp_error name_sexp "Atom expected"
| Atom (_, s) -> | Atom (_, A s) ->
match find_cstr cstrs sexp s with match find_cstr cstrs sexp s with
| C.Tuple t -> Constructor_args_spec.convert t.args t.rest sexp args (t.make loc) | C.Tuple t -> Constructor_args_spec.convert t.args t.rest sexp args (t.make loc)
| C.Record r -> record r.parse (List (loc, args)) | C.Record r -> record r.parse (List (loc, args))
@ -434,7 +423,7 @@ module Of_sexp = struct
let enum cstrs sexp = let enum cstrs sexp =
match sexp with match sexp with
| Quoted_string _ | List _ -> of_sexp_error sexp "Atom expected" | Quoted_string _ | List _ -> of_sexp_error sexp "Atom expected"
| Atom (_, s) -> | Atom (_, A s) ->
match match
List.find cstrs ~f:(fun (name, _) -> List.find cstrs ~f:(fun (name, _) ->
equal_cstr_name name s) equal_cstr_name name s)

17
src/sexp.mli
View File

@ -16,8 +16,10 @@ val load_many_or_ocaml_script : string -> sexps_or_ocaml_script
module type Combinators = sig module type Combinators = sig
type 'a t type 'a t
val unit : unit t val unit : unit t
val atom : string t
val quoted_string : string t val string : string t
(** Convert an [Atom] or a [Quoted_string] from/to a string. *)
val int : int t val int : int t
val float : float t val float : float t
val bool : bool t val bool : bool t
@ -27,15 +29,15 @@ module type Combinators = sig
val array : 'a t -> 'a array t val array : 'a t -> 'a array t
val option : 'a t -> 'a option t val option : 'a t -> 'a option t
val atom_set : String_set.t t val string_set : String_set.t t
(** [atom_set] is a conversion to/from a set of strings representing atoms. *) (** [atom_set] is a conversion to/from a set of strings representing atoms. *)
val atom_map : 'a t -> 'a String_map.t t val string_map : 'a t -> 'a String_map.t t
(** [atom_map conv]: given a conversion [conv] to/from ['a], returns (** [atom_map conv]: given a conversion [conv] to/from ['a], returns
a conversion to/from a map where the keys are atoms and the a conversion to/from a map where the keys are atoms and the
values are of type ['a]. *) values are of type ['a]. *)
val atom_hashtbl : 'a t -> (string, 'a) Hashtbl.t t val string_hashtbl : 'a t -> (string, 'a) Hashtbl.t t
(** [atom_hashtbl conv] is similar to [atom_map] for hash tables. *) (** [atom_hashtbl conv] is similar to [atom_map] for hash tables. *)
end end
@ -48,15 +50,12 @@ end with type sexp := t
module Of_sexp : sig module Of_sexp : sig
type ast = Ast.t = type ast = Ast.t =
| Atom of Loc.t * string | Atom of Loc.t * Atom.t
| Quoted_string of Loc.t * string | Quoted_string of Loc.t * string
| List of Loc.t * ast list | List of Loc.t * ast list
include Combinators with type 'a t = Ast.t -> 'a include Combinators with type 'a t = Ast.t -> 'a
val string : Ast.t -> string
(** Convert and [Atom] or a [Quoted_string] to s string. *)
val of_sexp_error : Ast.t -> string -> _ val of_sexp_error : Ast.t -> string -> _
val of_sexp_errorf : Ast.t -> ('a, unit, string, 'b) format4 -> 'a val of_sexp_errorf : Ast.t -> ('a, unit, string, 'b) format4 -> 'a

12
src/string_with_vars.ml
View File

@ -60,7 +60,7 @@ let rec of_tokens : Token.t list -> item list = function
let items_of_string s = of_tokens (Token.tokenise s) let items_of_string s = of_tokens (Token.tokenise s)
let t : Sexp.Of_sexp.ast -> t = function let t : Sexp.Of_sexp.ast -> t = function
| Atom(loc, s) -> { items = items_of_string s; loc; quoted = false } | Atom(loc, A s) -> { items = items_of_string s; loc; quoted = false }
| Quoted_string (loc, s) -> | Quoted_string (loc, s) ->
{ items = items_of_string s; loc; quoted = true } { items = items_of_string s; loc; quoted = true }
| List _ as sexp -> Sexp.Of_sexp.of_sexp_error sexp "Atom expected" | List _ as sexp -> Sexp.Of_sexp.of_sexp_error sexp "Atom expected"
@ -75,13 +75,15 @@ let virt_text pos s =
{ items = [Text s]; loc = Loc.of_pos pos; quoted = true } { items = [Text s]; loc = Loc.of_pos pos; quoted = true }
let sexp_of_var_syntax = function let sexp_of_var_syntax = function
| Parens -> Sexp.Atom "parens" | Parens -> Sexp.unsafe_atom_of_string "parens"
| Braces -> Sexp.Atom "braces" | Braces -> Sexp.unsafe_atom_of_string "braces"
let sexp_of_item = let sexp_of_item =
let open Sexp in function let open Sexp in function
| Text s -> List [Atom "text" ; Atom s] | Text s -> List [Sexp.unsafe_atom_of_string "text" ;
| Var (vs, s) -> List [sexp_of_var_syntax vs ; Atom s] Sexp.atom_or_quoted_string s]
| Var (vs, s) -> List [sexp_of_var_syntax vs ;
Sexp.atom_or_quoted_string s]
let sexp_of_t t = Sexp.To_sexp.list sexp_of_item t.items let sexp_of_t t = Sexp.To_sexp.list sexp_of_item t.items

8
src/super_context.ml
View File

@ -427,7 +427,7 @@ module Pkg_version = struct
module V = Vfile_kind.Make(struct type t = string option end) module V = Vfile_kind.Make(struct type t = string option end)
(functor (C : Sexp.Combinators) -> struct (functor (C : Sexp.Combinators) -> struct
let t = C.option C.atom let t = C.option C.string
end) end)
let spec sctx (p : Package.t) = let spec sctx (p : Package.t) =
@ -969,9 +969,9 @@ module PP = struct
let alias = Alias.lint ~dir in let alias = Alias.lint ~dir in
let add_alias fn build = let add_alias fn build =
Alias.add_action sctx.build_system alias build Alias.add_action sctx.build_system alias build
~stamp:(List [ Atom "lint" ~stamp:(List [ Sexp.unsafe_atom_of_string "lint"
; Sexp.To_sexp.(option atom) lib_name ; Sexp.To_sexp.(option string) lib_name
; Atom fn ; Sexp.atom fn
]) ])
in in
let lint = let lint =

2
src/usexp/parser_automaton_internal.ml
View File

@ -333,7 +333,7 @@ let eps_push_atom state stack =
Buffer.clear state.atom_buffer; Buffer.clear state.atom_buffer;
let stack = let stack =
if state.ignoring = 0 then if state.ignoring = 0 then
Sexp (Atom (make_loc state, str), stack) Sexp (Atom (make_loc state, A str), stack)
else else
stack stack
in in

4
src/usexp/sexp_ast.ml
View File

@ -5,7 +5,9 @@ module Loc = struct
} }
end end
type atom = A of string [@@unboxed]
type t = type t =
| Atom of Loc.t * string | Atom of Loc.t * atom
| Quoted_string of Loc.t * string | Quoted_string of Loc.t * string
| List of Loc.t * t list | List of Loc.t * t list

200
src/usexp/usexp.ml
View File

@ -13,95 +13,122 @@ end
module A = Parser_automaton_internal module A = Parser_automaton_internal
module Atom = struct module Atom = struct
type t = string type t = Sexp_ast.atom = A of string [@@unboxed]
let escaped_length s = let is_valid s =
let n = ref 0 in if s = "" then false
for i = 0 to String.length s - 1 do else
n := !n + try
(match String.unsafe_get s i with for i = 0 to String.length s - 1 do
| '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 match String.unsafe_get s i with
| ' ' .. '~' -> 1 | ' ' .. '~' -> ()
| _ -> 4) | _ -> raise Exit
done; done;
!n true
with Exit -> false
let must_escape s = (* XXX eventually we want to report a nice error message to the user
let len = String.length s in at the point the conversion is made. *)
len = 0 || escaped_length s > len let of_string s =
if is_valid s then A s
else invalid_arg(Printf.sprintf "Usexp.Atom.of_string: %S" s)
let escaped_internal s ~with_double_quotes ~always_quote = let of_int i = A (string_of_int i)
let n = escaped_length s in let of_float x = A (string_of_float x)
if n > 0 && n = String.length s then let of_bool x = A (string_of_bool x)
if always_quote then begin let of_int64 i = A (Int64.to_string i)
let s' = Bytes.create (n + 2) in let of_digest d = A (Digest.to_hex d)
Bytes.unsafe_set s' 0 '"';
Bytes.blit_string ~src:s ~src_pos:0 ~dst:s' ~dst_pos:1 ~len:n;
Bytes.unsafe_set s' (n + 1) '"';
Bytes.unsafe_to_string s'
end
else s
else begin
let s' = Bytes.create (n + if with_double_quotes then 2 else 0) in
let n = ref 0 in
if with_double_quotes then begin
Bytes.unsafe_set s' 0 '"';
n := 1
end;
for i = 0 to String.length s - 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;
if with_double_quotes then Bytes.unsafe_set s' !n '"';
Bytes.unsafe_to_string s'
end
let escaped s = let to_string (A s) = s
escaped_internal s ~with_double_quotes:false ~always_quote:false
let serialize s =
escaped_internal s ~with_double_quotes:true ~always_quote:false
let quote s =
escaped_internal s ~with_double_quotes:true ~always_quote:true
end end
type t = type t =
| Atom of string | Atom of Atom.t
| Quoted_string of string | Quoted_string of string
| List of t list | List of t list
type sexp = t type sexp = t
let atom s =
if Atom.is_valid s then Atom (A s)
else invalid_arg "Usexp.atom"
let unsafe_atom_of_string s = Atom(A s)
let atom_or_quoted_string s =
if Atom.is_valid s then Atom (A s)
else Quoted_string s
let quote_length s =
let n = ref 0 in
for i = 0 to String.length s - 1 do
n := !n + (match String.unsafe_get s i with
| '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2
| ' ' .. '~' -> 1
| _ -> 4)
done;
!n
let escape_to s ~dst:s' ~ofs =
let n = ref ofs in
for i = 0 to String.length s - 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
(* Escape [s] if needed. *)
let escaped s =
let n = quote_length s in
if n = 0 || n > String.length s then
let s' = Bytes.create n in
escape_to s ~dst:s' ~ofs:0;
Bytes.unsafe_to_string s'
else s
(* Surround [s] with quotes, escaping it if necessary. *)
let quoted s =
let len = String.length s in
let n = quote_length s in
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'
let rec to_string = function let rec to_string = function
| Atom s -> Atom.serialize s | Atom (A s) -> s
| Quoted_string s -> Atom.quote s | Quoted_string s -> quoted s
| List l -> Printf.sprintf "(%s)" (List.map l ~f:to_string |> String.concat ~sep:" ") | List l -> Printf.sprintf "(%s)" (List.map l ~f:to_string |> String.concat ~sep:" ")
let rec pp ppf = function let rec pp ppf = function
| Atom s -> | Atom (A s) ->
Format.pp_print_string ppf (Atom.serialize s) Format.pp_print_string ppf s
| Quoted_string s -> | Quoted_string s ->
Format.pp_print_string ppf (Atom.quote s) Format.pp_print_string ppf (quoted s)
| List [] -> | List [] ->
Format.pp_print_string ppf "()" Format.pp_print_string ppf "()"
| List (first :: rest) -> | List (first :: rest) ->
@ -127,26 +154,21 @@ let split_string s ~on =
in in
loop 0 0 loop 0 0
let pp_print_atom ppf ~serialize s = let pp_print_quoted_string ppf s =
if String.contains s '\n' then begin if String.contains s '\n' then begin
match split_string s ~on:'\n' with match split_string s ~on:'\n' with
| [] -> Format.pp_print_string ppf (serialize s) | [] -> Format.pp_print_string ppf (quoted s)
| first :: rest -> | first :: rest ->
Format.fprintf ppf "@[<hv 1>\"@{<atom>%s" (Atom.escaped first); Format.fprintf ppf "@[<hv 1>\"@{<atom>%s" (escaped first);
List.iter rest ~f:(fun s -> List.iter rest ~f:(fun s ->
Format.fprintf ppf "@,\\n%s" (Atom.escaped s)); Format.fprintf ppf "@,\\n%s" (escaped s));
Format.fprintf ppf "@}\"@]" Format.fprintf ppf "@}\"@]"
end else end else
Format.pp_print_string ppf (serialize s) Format.pp_print_string ppf (quoted s)
let rec pp_split_strings ppf = function let rec pp_split_strings ppf = function
| Atom s -> | Atom (A s) -> Format.pp_print_string ppf s
if Atom.must_escape s then | Quoted_string s -> pp_print_quoted_string ppf s
pp_print_atom ppf s ~serialize:Atom.serialize
else
Format.pp_print_string ppf s
| Quoted_string s ->
pp_print_atom ppf s ~serialize:Atom.quote
| List [] -> | List [] ->
Format.pp_print_string ppf "()" Format.pp_print_string ppf "()"
| List (first :: rest) -> | List (first :: rest) ->
@ -208,11 +230,15 @@ module Loc = Sexp_ast.Loc
module Ast = struct module Ast = struct
type t = Sexp_ast.t = type t = Sexp_ast.t =
| Atom of Loc.t * string | Atom of Loc.t * Atom.t
| Quoted_string of Loc.t * string | Quoted_string of Loc.t * string
| List of Loc.t * t list | List of Loc.t * t list
let loc (Atom (loc, _) | Quoted_string (loc, _) | List (loc, _)) = loc let atom_or_quoted_string loc s =
if Atom.is_valid s then Atom (loc, A s)
else Quoted_string (loc, s)
let loc (Atom (loc, _) | Quoted_string (loc, _) | List (loc, _)) = loc
let rec remove_locs : t -> sexp = function let rec remove_locs : t -> sexp = function
| Atom (_, s) -> Atom s | Atom (_, s) -> Atom s
@ -221,7 +247,7 @@ module Ast = struct
module Token = struct module Token = struct
type t = type t =
| Atom of Loc.t * string | Atom of Loc.t * Atom.t
| String of Loc.t * string | String of Loc.t * string
| Lparen of Loc.t | Lparen of Loc.t
| Rparen of Loc.t | Rparen of Loc.t

35
src/usexp/usexp.mli
View File

@ -1,17 +1,24 @@
(** Parsing of s-expressions *) (** Parsing of s-expressions *)
module Atom : sig module Atom : sig
type t = string type t = private A of string [@@unboxed]
(** Acceptable atoms are composed of chars in the range [' ' .. '~']
and must be nonempty. *)
(** Whether the atom must be escaped when serialized *) val is_valid : string -> bool
val must_escape : t -> bool (** [is_valid s] checks that [s] respects the constraints to be an atom. *)
(** Escape all special characters in the atom *) val of_string : string -> t
val escaped : t -> string (** Convert a string to an atom. If the string contains invalid
characters, raise [Invalid_argument]. *)
(** [serialize t] is the serialized representation of [t], so either val of_int : int -> t
[t] either [escaped t] surrounded by double quotes. *) val of_float : float -> t
val serialize : t -> string val of_bool : bool -> t
val of_int64 : Int64.t -> t
val of_digest : Digest.t -> t
val to_string : t -> string
end end
module Loc : sig module Loc : sig
@ -27,6 +34,14 @@ type t =
| Quoted_string of string | Quoted_string of string
| List of t list | List of t list
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 *) (** Serialize a S-expression *)
val to_string : t -> string val to_string : t -> string
@ -50,13 +65,15 @@ module Ast : sig
| Quoted_string of Loc.t * string | Quoted_string of Loc.t * string
| List of Loc.t * t list | List of Loc.t * t list
val atom_or_quoted_string : Loc.t -> string -> t
val loc : t -> Loc.t val loc : t -> Loc.t
val remove_locs : t -> sexp val remove_locs : t -> sexp
module Token : sig module Token : sig
type t = type t =
| Atom of Loc.t * string | Atom of Loc.t * Atom.t
| String of Loc.t * string | String of Loc.t * string
| Lparen of Loc.t | Lparen of Loc.t
| Rparen of Loc.t | Rparen of Loc.t

7
src/utils.ml
View File

@ -192,9 +192,10 @@ module Cached_digest = struct
Pmap.add acc ~key ~data) Pmap.add acc ~key ~data)
|> Path.Map.bindings |> Path.Map.bindings
|> List.map ~f:(fun (path, file) -> |> List.map ~f:(fun (path, file) ->
Sexp.List [ Atom (Path.to_string path) Sexp.List [ Quoted_string (Path.to_string path)
; Atom (Digest.to_hex file.digest) ; Atom (Sexp.Atom.of_digest file.digest)
; Atom (Int64.to_string (Int64.bits_of_float file.timestamp)) ; Atom (Sexp.Atom.of_int64
(Int64.bits_of_float file.timestamp))
])) ]))
in in
if Sys.file_exists "_build" then if Sys.file_exists "_build" then

3
src/with_required_by.ml
View File

@ -16,7 +16,8 @@ module Entry = struct
| Library (path, lib_name) -> | Library (path, lib_name) ->
sprintf "library %S in %s" lib_name (Path.to_string_maybe_quoted path) sprintf "library %S in %s" lib_name (Path.to_string_maybe_quoted path)
| Preprocess l -> | Preprocess l ->
Sexp.to_string (List [Atom "pps"; Sexp.To_sexp.(list atom) l]) Sexp.to_string (List [Sexp.unsafe_atom_of_string "pps";
Sexp.To_sexp.(list string) l])
| Loc loc -> | Loc loc ->
Loc.to_file_colon_line loc Loc.to_file_colon_line loc

2
src/workspace.ml
View File

@ -39,7 +39,7 @@ module Context = struct
type t = Default of Target.t list | Opam of Opam.t type t = Default of Target.t list | Opam of Opam.t
let t = function let t = function
| Atom (_, "default") -> Default [Native] | Atom (_, A "default") -> Default [Native]
| List (_, List _ :: _) as sexp -> Opam (record Opam.t sexp) | List (_, List _ :: _) as sexp -> Opam (record Opam.t sexp)
| sexp -> | sexp ->
sum sum