From 67c9363c7db8c82d759dac469b26f1d1dc09d21d Mon Sep 17 00:00:00 2001 From: Christophe Troestler Date: Mon, 12 Feb 2018 23:35:56 +0100 Subject: [PATCH] Use more precise combinators "atom" and "quoted_string" --- src/action.ml | 4 ++-- src/context.ml | 16 ++++++++-------- src/gen_rules.ml | 2 +- src/ocamldep.ml | 2 +- src/ordered_set_lang.ml | 2 +- src/path.ml | 2 +- src/sexp.ml | 37 ++++++++++++++++++++++++------------- src/sexp.mli | 20 ++++++++++++++++---- src/super_context.ml | 6 +++--- src/with_required_by.ml | 2 +- 10 files changed, 58 insertions(+), 35 deletions(-) diff --git a/src/action.ml b/src/action.ml index 761d77c3..64680056 100644 --- a/src/action.ml +++ b/src/action.ml @@ -180,7 +180,7 @@ module Prog = struct let sexp_of_t = function | Ok s -> Path.sexp_of_t s - | Error (e : Not_found.t) -> Sexp.To_sexp.string e.program + | Error (e : Not_found.t) -> Sexp.To_sexp.atom e.program end module type Ast = Action_intf.Ast @@ -192,7 +192,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.string + let sexp_of_t = Sexp.To_sexp.atom end include Make_ast diff --git a/src/context.ml b/src/context.ml index afba65c6..294ed3c4 100644 --- a/src/context.ml +++ b/src/context.ml @@ -13,8 +13,8 @@ module Kind = struct let sexp_of_t : t -> Sexp.t = function | Default -> Atom "default" | Opam o -> - Sexp.To_sexp.(record [ "root" , string o.root - ; "switch", string o.switch + Sexp.To_sexp.(record [ "root" , atom o.root + ; "switch", atom 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", string t.name + [ "name", atom t.name ; "kind", Kind.sexp_of_t t.kind ; "merlin", bool t.merlin - ; "for_host", option string (Option.map t.for_host ~f:(fun t -> t.name)) + ; "for_host", option atom (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 string string) (Env_var_map.bindings t.env_extra) + ; "env", list (pair atom atom) (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", string_hashtbl string t.opam_var_cache - ; "ocamlc_config", list (pair string string) t.ocamlc_config - ; "which", string_hashtbl (option path) t.which_cache + ; "opam_vars", atom_hashtbl atom t.opam_var_cache + ; "ocamlc_config", list (pair atom atom) t.ocamlc_config + ; "which", atom_hashtbl (option path) t.which_cache ] let compare a b = compare a.name b.name diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 68af9dee..a71ab0b0 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -84,7 +84,7 @@ module Gen(P : Params) = struct \n\ \nThis will become an error in the future." (Sexp.to_string (List [ Atom "modules_without_implementation" - ; Sexp.To_sexp.(list string) should_be_listed + ; Sexp.To_sexp.(list atom) should_be_listed ])) | Some loc -> Loc.warn loc diff --git a/src/ocamldep.ml b/src/ocamldep.ml index 84ba559b..bb396329 100644 --- a/src/ocamldep.ml +++ b/src/ocamldep.ml @@ -15,7 +15,7 @@ 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 string) (String_map.keys t.per_module) + ; "modules", Sexp.To_sexp.(list atom) (String_map.keys t.per_module) ; "module", Atom m.name ] diff --git a/src/ordered_set_lang.ml b/src/ordered_set_lang.ml index 365878a2..5417bddf 100644 --- a/src/ordered_set_lang.ml +++ b/src/ordered_set_lang.ml @@ -195,7 +195,7 @@ module Unexpanded = struct Sexp.code_error "Ordered_set_lang.Unexpanded.expand" [ "included-file", Atom fn - ; "files", Sexp.To_sexp.(list string) (String_map.keys files_contents) + ; "files", Sexp.To_sexp.(list atom) (String_map.keys files_contents) ] in parse_general sexp ~f:(fun sexp -> diff --git a/src/path.ml b/src/path.ml index b25d399a..2a25b861 100644 --- a/src/path.ml +++ b/src/path.ml @@ -222,7 +222,7 @@ let compare = String.compare module Set = struct include String_set - let sexp_of_t t = Sexp.To_sexp.(list string) (String_set.elements t) + let sexp_of_t t = Sexp.To_sexp.(list atom) (String_set.elements t) let of_string_set = map end diff --git a/src/sexp.ml b/src/sexp.ml index e192573f..03e58596 100644 --- a/src/sexp.ml +++ b/src/sexp.ml @@ -68,7 +68,8 @@ let load_many_or_ocaml_script fname = module type Combinators = sig type 'a t val unit : unit t - val string : string t + val atom : string t + val quoted_string : string t val int : int t val float : float t val bool : bool t @@ -77,15 +78,16 @@ 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 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 + 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 end module To_sexp = struct type nonrec 'a t = 'a -> t let unit () = List [] - let string s = Quoted_string s + 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) @@ -96,12 +98,12 @@ module To_sexp = struct let option f = function | None -> List [] | Some x -> List [f x] - let string_set set = list string (String_set.elements set) - let string_map f map = list (pair string f) (String_map.bindings map) + let atom_set set = list atom (String_set.elements set) + let atom_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 string_hashtbl f h = - string_map f + let atom_hashtbl f h = + atom_map f (Hashtbl.fold h ~init:String_map.empty ~f:(fun ~key ~data acc -> String_map.add acc ~key ~data)) end @@ -124,6 +126,15 @@ 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 | Quoted_string (_, s) -> s @@ -163,15 +174,15 @@ module Of_sexp = struct | List (_, [x]) -> Some (f x) | sexp -> of_sexp_error sexp "S-expression of the form () or (_) expected" - let string_set sexp = String_set.of_list (list string sexp) - let string_map f sexp = + let atom_set sexp = String_set.of_list (list string sexp) + let atom_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 string_hashtbl f sexp = - let map = string_map f sexp in + let atom_hashtbl f sexp = + let map = atom_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); diff --git a/src/sexp.mli b/src/sexp.mli index 36af356d..8258374a 100644 --- a/src/sexp.mli +++ b/src/sexp.mli @@ -16,7 +16,8 @@ val load_many_or_ocaml_script : string -> sexps_or_ocaml_script module type Combinators = sig type 'a t val unit : unit t - val string : string t + val atom : string t + val quoted_string : string t val int : int t val float : float t val bool : bool t @@ -25,9 +26,17 @@ 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 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 + + val atom_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 + (** [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 + (** [atom_hashtbl conv] is similar to [atom_map] for hash tables. *) end module To_sexp : sig @@ -45,6 +54,9 @@ module Of_sexp : sig 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 diff --git a/src/super_context.ml b/src/super_context.ml index 4ec2e691..48b9d1cd 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -111,7 +111,7 @@ let create (struct type t = Lib.t list end) (struct open Sexp.To_sexp - let t _dir l = list string (List.map l ~f:Lib.best_name) + let t _dir l = list atom (List.map l ~f:Lib.best_name) end) (struct open Sexp.Of_sexp @@ -439,7 +439,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.string + let t = C.option C.atom end) let spec sctx (p : Package.t) = @@ -966,7 +966,7 @@ module PP = struct let add_alias fn build = Alias.add_action sctx.build_system alias build ~stamp:(List [ Atom "lint" - ; Sexp.To_sexp.(option string) lib_name + ; Sexp.To_sexp.(option atom) lib_name ; Atom fn ]) in diff --git a/src/with_required_by.ml b/src/with_required_by.ml index 845de6e4..9faadff4 100644 --- a/src/with_required_by.ml +++ b/src/with_required_by.ml @@ -13,7 +13,7 @@ module Entry = struct | Path p -> Utils.describe_target p | Alias p -> "alias " ^ Utils.describe_target p | Library s -> sprintf "library %S" s - | Preprocess l -> Sexp.to_string (List [Atom "pps"; Sexp.To_sexp.(list string) l]) + | Preprocess l -> Sexp.to_string (List [Atom "pps"; Sexp.To_sexp.(list atom) l]) let pp ppf x = Format.pp_print_string ppf (to_string x)