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 ]
; (match rule.context with
| None -> []
| Some c -> ["context", Atom c.name])
| Some c -> ["context",
Sexp.atom_or_quoted_string c.name])
; [ "action" , sexp_of_action rule.action ]
])
in

58
src/action.ml
View File

@ -69,38 +69,45 @@ struct
let rec sexp_of_t : _ -> Sexp.t =
let path = Path.sexp_of_t and string = String.sexp_of_t in
function
| Run (a, xs) -> List (Atom "run" :: Program.sexp_of_t a :: List.map xs ~f:string)
| Chdir (a, r) -> List [Atom "chdir" ; path a ; sexp_of_t r]
| Setenv (k, v, r) -> List [Atom "setenv" ; string k ; string v ; sexp_of_t r]
| 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]
| 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
; sexp_of_t 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
]
| Progn l -> List (Atom "progn" :: List.map l ~f:sexp_of_t)
| Echo x -> List [Atom "echo"; string x]
| Cat x -> List [Atom "cat"; path x]
| Progn l -> List (Sexp.unsafe_atom_of_string "progn"
:: List.map l ~f:sexp_of_t)
| 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) ->
List [Atom "copy"; path x; path y]
List [Sexp.unsafe_atom_of_string "copy"; path x; path 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) ->
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)]
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 (List.map paths ~f:path)]
| 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 } ->
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 chdir path t = Chdir (path, t)
@ -180,7 +187,7 @@ module Prog = struct
let sexp_of_t = function
| 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
module type Ast = Action_intf.Ast
@ -192,7 +199,7 @@ 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.atom
let sexp_of_t = Sexp.To_sexp.string
end
include Make_ast
@ -345,7 +352,7 @@ module Unexpanded = struct
Loc.fail loc
"(mkdir ...) is not supported for paths outside of the workspace:\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 Program = Unresolved.Program
@ -594,7 +601,7 @@ module Promotion = struct
}
let t = function
| Sexp.Ast.List (_, [src; Atom (_, "as"); dst]) ->
| Sexp.Ast.List (_, [src; Atom (_, A "as"); dst]) ->
{ src = Path.t src
; dst = Path.t dst
}
@ -602,7 +609,8 @@ module Promotion = struct
Sexp.Of_sexp.of_sexp_errorf sexp "(<file> as <file>) expected"
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 []

3
src/build_system.ml
View File

@ -1086,7 +1086,8 @@ module Trace = struct
Pmap.add acc ~key ~data)
|> Path.Map.bindings
|> 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
if Sys.file_exists "_build" then
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
let sexp_of_t : t -> Sexp.t = function
| Default -> Atom "default"
| Default -> Sexp.unsafe_atom_of_string "default"
| Opam o ->
Sexp.To_sexp.(record [ "root" , atom o.root
; "switch", atom o.switch
Sexp.To_sexp.(record [ "root" , string o.root
; "switch", string o.switch
])
end
@ -92,10 +92,10 @@ let sexp_of_t t =
let open Sexp.To_sexp in
let path = Path.sexp_of_t in
record
[ "name", atom t.name
[ "name", string t.name
; "kind", Kind.sexp_of_t t.kind
; "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
; "toplevel_path", option path t.toplevel_path
; "ocaml_bin", path t.ocaml_bin
@ -104,13 +104,13 @@ let sexp_of_t t =
; "ocamlopt", option path t.ocamlopt
; "ocamldep", path t.ocamldep
; "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)
; "arch_sixtyfour", bool t.arch_sixtyfour
; "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
; "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

8
src/gen_rules.ml
View File

@ -101,8 +101,10 @@ module Gen(P : Params) = struct
\n %s\
\n\
\nThis will become an error in the future."
(Sexp.to_string (List [ Atom "modules_without_implementation"
; Sexp.To_sexp.(list atom) should_be_listed
(let tag = Sexp.unsafe_atom_of_string
"modules_without_implementation" in
Sexp.to_string (List [ tag
; Sexp.To_sexp.(list string) should_be_listed
]))
| Some loc ->
Loc.warn loc
@ -804,7 +806,7 @@ module Gen(P : Params) = struct
let stamp =
let module S = Sexp.To_sexp in
Sexp.List
[ Atom "user-alias"
[ Sexp.unsafe_atom_of_string "user-alias"
; S.list Jbuild.Dep_conf.sexp_of_t alias_conf.deps
; 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)
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)
let split l =
@ -246,15 +246,18 @@ module Dep_conf = struct
open Sexp
let sexp_of_t = function
| 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 ->
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 ->
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 ->
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 ->
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
module Preprocess = struct
@ -283,7 +286,7 @@ module Per_module = struct
let t ~default a sexp =
match sexp with
| List (_, Atom (_, "per_module") :: rest) -> begin
| List (_, Atom (_, A "per_module") :: rest) -> begin
List.map rest ~f:(fun sexp ->
let pp, names = pair a module_names sexp in
(String_set.elements names, pp))
@ -364,7 +367,7 @@ module Lib_dep = struct
let choice = function
| List (_, l) as sexp ->
let rec loop required forbidden = function
| [Atom (_, "->"); fsexp] ->
| [Atom (_, A "->"); fsexp] ->
let common = String_set.inter required forbidden in
if not (String_set.is_empty common) then
of_sexp_errorf sexp
@ -374,10 +377,10 @@ module Lib_dep = struct
; forbidden
; file = file fsexp
}
| Atom (_, "->") :: _
| Atom (_, A "->") :: _
| List _ :: _ | [] ->
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
if len > 0 && s.[0] = '!' then
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"
let t = function
| Atom (_, s) ->
| Atom (_, A 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
; choices = List.map libs ~f:choice
; loc
@ -641,8 +644,8 @@ module Install_conf = struct
let file sexp =
match sexp with
| Atom (_, src) -> { src; dst = None }
| List (_, [Atom (_, src); Atom (_, "as"); Atom (_, dst)]) ->
| Atom (_, A src) -> { src; dst = None }
| List (_, [Atom (_, A src); Atom (_, A "as"); Atom (_, A dst)]) ->
{ src; dst = Some dst }
| _ ->
of_sexp_error sexp
@ -1064,7 +1067,7 @@ module Stanzas = struct
and parse ~default_version ~file ~include_stack pkgs sexps =
let versions, sexps =
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)
| sexp -> Inr sexp)
in

15
src/lib.ml
View File

@ -452,19 +452,22 @@ and resolve_name db name ~stack =
in
(* Add [init] to the table, to detect loops *)
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 =
match x with
| Initializing x ->
Sexp.List [Atom "Initializing"; Path.sexp_of_t x.path]
| Done (Ok t) -> List [Atom "Ok"; Path.sexp_of_t t.src_dir]
| Done (Error Not_found) -> Atom "Not_found"
Sexp.List [Sexp.unsafe_atom_of_string "Initializing";
Path.sexp_of_t x.path]
| 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; _ })) ->
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
Sexp.code_error
"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)
; "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 open Sexp.To_sexp in
atom_map atom t.bindings
string_map Sexp.atom_or_quoted_string t.bindings
let read ~ocamlc ~env =
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 ->
Sexp.code_error "Ocamldep.Dep_graph.deps_of"
[ "dir", Path.sexp_of_t t.dir
; "modules", Sexp.To_sexp.(list atom) (String_map.keys t.per_module)
; "module", Atom m.name
; "modules", Sexp.To_sexp.(list string) (String_map.keys t.per_module)
; "module", Sexp.atom m.name
]
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 rec of_sexp : Sexp.Ast.t -> _ = function
| Atom (loc, "\\") -> Loc.fail loc "unexpected \\"
| (Atom (_, "") | Quoted_string (_, _)) as t -> Ast.Element (f t)
| Atom (loc, s) as t ->
| Atom (loc, A "\\") -> Loc.fail loc "unexpected \\"
| (Atom (_, A "") | Quoted_string (_, _)) as t -> Ast.Element (f t)
| Atom (loc, A s) as t ->
if s.[0] = ':' then
Special (loc, String.sub s ~pos:1 ~len:(String.length s - 1))
else
Element (f t)
| List (_, sexps) -> of_sexps [] sexps
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 ->
of_sexps (of_sexp elt :: acc) sexps
| [] -> Union (List.rev acc)
@ -43,7 +44,7 @@ let parse_general sexp ~f =
let t sexp : t =
let ast =
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)
in
{ ast
@ -194,8 +195,8 @@ module Unexpanded = struct
| None ->
Sexp.code_error
"Ordered_set_lang.Unexpanded.expand"
[ "included-file", Atom fn
; "files", Sexp.To_sexp.(list atom) (String_map.keys files_contents)
[ "included-file", Quoted_string fn
; "files", Sexp.To_sexp.(list string) (String_map.keys files_contents)
]
in
parse_general sexp ~f:(fun sexp ->

11
src/path.ml
View File

@ -222,7 +222,7 @@ let compare = String.compare
module Set = struct
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
end
@ -270,7 +270,7 @@ let of_string ?error_loc s =
s
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 =
if is_local fn then
@ -424,7 +424,8 @@ let explode_exn t =
else if is_local t then
String.split t ~on:'/'
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 readdir t = Sys.readdir (to_string t) |> Array.to_list
@ -457,8 +458,8 @@ let insert_after_build_dir_exn =
let error a b =
Sexp.code_error
"Path.insert_after_build_dir_exn"
[ "path" , Atom a
; "insert", Atom b
[ "path" , Sexp.unsafe_atom_of_string a
; "insert", Sexp.unsafe_atom_of_string b
]
in
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
Sexp.code_error "Scope.DB.find_by_dir got an invalid path"
[ "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
Hashtbl.add t.by_dir ~key:d ~data:scope;
@ -42,8 +42,8 @@ module DB = struct
| Some x -> x
| None ->
Sexp.code_error "Scope.DB.find_by_name"
[ "name" , Sexp.To_sexp.(option atom) name
; "context", Sexp.To_sexp.atom t.context
[ "name" , Sexp.To_sexp.(option string) name
; "context", Sexp.To_sexp.string t.context
]
let create ~scopes ~context ~installed_libs internal_libs =
@ -55,7 +55,7 @@ module DB = struct
| Ok x -> x
| Error (_name, scope1, scope2) ->
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)
in
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 =
code_errorf "%a" pp
(List (Atom message
(List (Usexp.atom_or_quoted_string message
:: List.map vars ~f:(fun (name, value) ->
List [Atom name; value])))
List [Usexp.atom_or_quoted_string name; value])))
let buf_len = 65_536
@ -68,8 +68,7 @@ let load_many_or_ocaml_script fname =
module type Combinators = sig
type 'a t
val unit : unit t
val atom : string t
val quoted_string : string t
val string : string t
val int : int t
val float : float t
val bool : bool t
@ -78,19 +77,18 @@ module type Combinators = sig
val list : 'a t -> 'a list t
val array : 'a t -> 'a array t
val option : 'a t -> 'a option t
val atom_set : String_set.t t
val atom_map : 'a t -> 'a String_map.t t
val atom_hashtbl : 'a t -> (string, 'a) Hashtbl.t 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
module To_sexp = struct
type nonrec 'a t = 'a -> t
let unit () = List []
let atom a = Atom a
let quoted_string s = Quoted_string s
let int n = Atom (string_of_int n)
let float f = Atom (string_of_float f)
let bool b = Atom (string_of_bool b)
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 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)
@ -98,19 +96,19 @@ module To_sexp = struct
let option f = function
| None -> List []
| Some x -> List [f x]
let atom_set set = list atom (String_set.elements set)
let atom_map f map = list (pair atom f) (String_map.bindings map)
let string_set set = list atom (String_set.elements set)
let string_map f map = list (pair atom f) (String_map.bindings map)
let record l =
List (List.map l ~f:(fun (n, v) -> List [Atom n; v]))
let atom_hashtbl f h =
atom_map f
List (List.map l ~f:(fun (n, v) -> List [Atom(Atom.of_string n); v]))
let string_hashtbl f h =
string_map f
(Hashtbl.fold h ~init:String_map.empty ~f:(fun ~key ~data acc ->
String_map.add acc ~key ~data))
end
module Of_sexp = struct
type ast = Ast.t =
| Atom of Loc.t * string
| Atom of Loc.t * Atom.t
| Quoted_string of Loc.t * string
| List of Loc.t * ast list
@ -126,33 +124,24 @@ module Of_sexp = struct
| List (_, []) -> ()
| 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
| Atom (_, s) -> s
| Atom (_, A s) -> s
| Quoted_string (_, s) -> s
| List _ as sexp -> of_sexp_error sexp "Atom or quoted string expected"
let int sexp = match sexp with
| Atom (_, s) -> (try int_of_string s
with _ -> of_sexp_error sexp "Integer expected")
| Atom (_, A s) -> (try int_of_string s
with _ -> of_sexp_error sexp "Integer expected")
| _ -> of_sexp_error sexp "Integer expected"
let float sexp = match sexp with
| Atom (_, s) -> (try float_of_string s
with _ -> of_sexp_error sexp "Float expected")
| Atom (_, A s) -> (try float_of_string s
with _ -> of_sexp_error sexp "Float expected")
| _ -> of_sexp_error sexp "Float expected"
let bool = function
| Atom (_, "true") -> true
| Atom (_, "false") -> false
| Atom (_, A "true") -> true
| Atom (_, A "false") -> false
| sexp -> of_sexp_error sexp "'true' or 'false' expected"
let pair fa fb = function
@ -174,15 +163,15 @@ module Of_sexp = struct
| List (_, [x]) -> Some (f x)
| sexp -> of_sexp_error sexp "S-expression of the form () or (_) expected"
let atom_set sexp = String_set.of_list (list string sexp)
let atom_map f sexp =
let string_set sexp = String_set.of_list (list string sexp)
let string_map f sexp =
match String_map.of_alist (list (pair string f) sexp) with
| Ok x -> x
| Error (key, _v1, _v2) ->
of_sexp_error sexp (sprintf "key %S present multiple times" key)
let atom_hashtbl f sexp =
let map = atom_map f sexp in
let string_hashtbl f sexp =
let map = string_map f sexp in
let tbl = Hashtbl.create (String_map.cardinal map + 32) in
String_map.iter map ~f:(fun ~key ~data ->
Hashtbl.add tbl ~key ~data);
@ -303,11 +292,11 @@ module Of_sexp = struct
let unparsed =
List.fold_left sexps ~init:Name_map.empty ~f:(fun acc sexp ->
match sexp with
| List (_, [Atom (_, name)]) ->
| List (_, [Atom (_, A name)]) ->
Name_map.add acc ~key:name ~data:{ value = None; entry = sexp }
| List (_, [name_sexp; value]) -> begin
match name_sexp with
| Atom (_, name) ->
| Atom (_, A name) ->
Name_map.add acc ~key:name ~data:{ value = Some value;
entry = sexp }
| List _ | Quoted_string _ ->
@ -416,7 +405,7 @@ module Of_sexp = struct
let sum cstrs sexp =
match sexp with
| Atom (loc, s) -> begin
| Atom (loc, A s) -> begin
match find_cstr cstrs sexp s with
| C.Tuple t -> Constructor_args_spec.convert t.args t.rest sexp [] (t.make loc)
| C.Record _ -> of_sexp_error sexp "'%s' expect arguments"
@ -426,7 +415,7 @@ module Of_sexp = struct
| List (loc, name_sexp :: args) ->
match name_sexp with
| Quoted_string _ | List _ -> of_sexp_error name_sexp "Atom expected"
| Atom (_, s) ->
| Atom (_, A s) ->
match find_cstr cstrs sexp s with
| 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))
@ -434,7 +423,7 @@ module Of_sexp = struct
let enum cstrs sexp =
match sexp with
| Quoted_string _ | List _ -> of_sexp_error sexp "Atom expected"
| Atom (_, s) ->
| Atom (_, A s) ->
match
List.find cstrs ~f:(fun (name, _) ->
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
type 'a 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 float : float t
val bool : bool t
@ -27,15 +29,15 @@ module type Combinators = sig
val array : 'a t -> 'a array 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. *)
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
a conversion to/from a map where the keys are atoms and the
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. *)
end
@ -48,15 +50,12 @@ end with type sexp := t
module Of_sexp : sig
type ast = Ast.t =
| Atom of Loc.t * string
| Atom of Loc.t * Atom.t
| Quoted_string of Loc.t * string
| List of Loc.t * ast list
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_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 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) ->
{ items = items_of_string s; loc; quoted = true }
| 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 }
let sexp_of_var_syntax = function
| Parens -> Sexp.Atom "parens"
| Braces -> Sexp.Atom "braces"
| Parens -> Sexp.unsafe_atom_of_string "parens"
| Braces -> Sexp.unsafe_atom_of_string "braces"
let sexp_of_item =
let open Sexp in function
| Text s -> List [Atom "text" ; Atom s]
| Var (vs, s) -> List [sexp_of_var_syntax vs ; Atom s]
| Text s -> List [Sexp.unsafe_atom_of_string "text" ;
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

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)
(functor (C : Sexp.Combinators) -> struct
let t = C.option C.atom
let t = C.option C.string
end)
let spec sctx (p : Package.t) =
@ -969,9 +969,9 @@ module PP = struct
let alias = Alias.lint ~dir in
let add_alias fn build =
Alias.add_action sctx.build_system alias build
~stamp:(List [ Atom "lint"
; Sexp.To_sexp.(option atom) lib_name
; Atom fn
~stamp:(List [ Sexp.unsafe_atom_of_string "lint"
; Sexp.To_sexp.(option string) lib_name
; Sexp.atom fn
])
in
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;
let stack =
if state.ignoring = 0 then
Sexp (Atom (make_loc state, str), stack)
Sexp (Atom (make_loc state, A str), stack)
else
stack
in

4
src/usexp/sexp_ast.ml
View File

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

200
src/usexp/usexp.ml
View File

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

35
src/usexp/usexp.mli
View File

@ -1,17 +1,24 @@
(** Parsing of s-expressions *)
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 must_escape : t -> bool
val is_valid : string -> bool
(** [is_valid s] checks that [s] respects the constraints to be an atom. *)
(** Escape all special characters in the atom *)
val escaped : t -> string
val of_string : string -> t
(** 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
[t] either [escaped t] surrounded by double quotes. *)
val serialize : 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
val to_string : t -> string
end
module Loc : sig
@ -27,6 +34,14 @@ type t =
| Quoted_string of string
| 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 *)
val to_string : t -> string
@ -50,13 +65,15 @@ module Ast : sig
| Quoted_string of Loc.t * string
| 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
module Token : sig
type t =
| Atom of Loc.t * string
| Atom of Loc.t * Atom.t
| String of Loc.t * string
| Lparen 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)
|> Path.Map.bindings
|> List.map ~f:(fun (path, file) ->
Sexp.List [ Atom (Path.to_string path)
; Atom (Digest.to_hex file.digest)
; Atom (Int64.to_string (Int64.bits_of_float file.timestamp))
Sexp.List [ Quoted_string (Path.to_string path)
; Atom (Sexp.Atom.of_digest file.digest)
; Atom (Sexp.Atom.of_int64
(Int64.bits_of_float file.timestamp))
]))
in
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) ->
sprintf "library %S in %s" lib_name (Path.to_string_maybe_quoted path)
| 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.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
let t = function
| Atom (_, "default") -> Default [Native]
| Atom (_, A "default") -> Default [Native]
| List (_, List _ :: _) as sexp -> Opam (record Opam.t sexp)
| sexp ->
sum