Dune & Jbuild validation for atoms
Atoms can now be constructed and pretty printed with a syntax = Jbuild | Dune. The syntax controls validation that will be used to make sure we are printing something/reading valid Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>
This commit is contained in:
parent
2ed5f3fcfd
commit
ad3a95655d
|
@ -149,8 +149,7 @@ module Lang = struct
|
|||
in
|
||||
let ver =
|
||||
Sexp.Of_sexp.parse Syntax.Version.t Univ_map.empty
|
||||
(Atom (ver_loc, Sexp.Atom.of_string ver))
|
||||
in
|
||||
(Atom (ver_loc, Sexp.Atom.of_string_exn Sexp.Atom.Dune ver)) in
|
||||
match Hashtbl.find langs name with
|
||||
| None ->
|
||||
Loc.fail name_loc "Unknown language %S.%s" name
|
||||
|
|
|
@ -11,7 +11,8 @@ let int n = Usexp.Atom (Usexp.Atom.of_int n)
|
|||
let string = Usexp.atom_or_quoted_string
|
||||
let record l =
|
||||
let open Usexp in
|
||||
List (List.map l ~f:(fun (n, v) -> List [Atom(Atom.of_string n); v]))
|
||||
List (List.map l ~f:(fun (n, v) ->
|
||||
List [Atom(Atom.of_string_exn Atom.Dune n); v]))
|
||||
|
||||
let sexp_of_position_no_file (p : Lexing.position) =
|
||||
record
|
||||
|
|
|
@ -34,7 +34,8 @@ module To_sexp = struct
|
|||
let string_set set = list atom (String.Set.to_list set)
|
||||
let string_map f map = list (pair atom f) (String.Map.to_list map)
|
||||
let record l =
|
||||
List (List.map l ~f:(fun (n, v) -> List [Atom(Atom.of_string n); v]))
|
||||
List (List.map l ~f:(fun (n, v) ->
|
||||
List [Atom(Atom.of_string_exn Usexp.Atom.Dune n); v]))
|
||||
let string_hashtbl f h =
|
||||
string_map f
|
||||
(Hashtbl.foldi h ~init:String.Map.empty ~f:(fun key data acc ->
|
||||
|
@ -54,7 +55,7 @@ module To_sexp = struct
|
|||
|
||||
let record_fields (l : field list) =
|
||||
List (List.filter_map l ~f:(fun (k, v) ->
|
||||
Option.map v ~f:(fun v -> List[Atom (Atom.of_string k); v])))
|
||||
Option.map v ~f:(fun v -> List[Atom (Atom.of_string_exn Atom.Dune k); v])))
|
||||
|
||||
let unknown _ = unsafe_atom_of_string "<unknown>"
|
||||
end
|
||||
|
@ -296,13 +297,13 @@ module Of_sexp = struct
|
|||
let string = plain_string (fun ~loc:_ x -> x)
|
||||
let int =
|
||||
basic "Integer" (fun s ->
|
||||
match int_of_string s with
|
||||
match int_of_string (s Atom.Dune) with
|
||||
| x -> Ok x
|
||||
| exception _ -> Error ())
|
||||
|
||||
let float =
|
||||
basic "Float" (fun s ->
|
||||
match float_of_string s with
|
||||
match float_of_string (s Atom.Dune) with
|
||||
| x -> Ok x
|
||||
| exception _ -> Error ())
|
||||
|
||||
|
|
|
@ -0,0 +1,55 @@
|
|||
type t = A of string [@@unboxed]
|
||||
|
||||
let invalid_argf fmt = Printf.ksprintf invalid_arg fmt
|
||||
|
||||
type syntax = Jbuild | Dune
|
||||
|
||||
let string_of_syntax = function
|
||||
| Jbuild -> "jbuild"
|
||||
| Dune -> "dune"
|
||||
|
||||
let (is_valid_jbuild, is_valid_dune) =
|
||||
let rec jbuild s i len =
|
||||
i = len ||
|
||||
match String.unsafe_get s i with
|
||||
| '"' | '(' | ')' | ';' | '\000'..'\032' | '\127'..'\255' -> false
|
||||
| _ -> jbuild s (i + 1) len
|
||||
in
|
||||
let rec dune s i len =
|
||||
i = len ||
|
||||
match String.unsafe_get s i with
|
||||
| '%' | '"' | '(' | ')' | ';' | '\000'..'\032' | '\127'..'\255' -> false
|
||||
| _ -> dune s (i + 1) len
|
||||
in
|
||||
let make looper s =
|
||||
let len = String.length s in
|
||||
len > 0 && looper s 0 len
|
||||
in
|
||||
(make jbuild, make dune)
|
||||
|
||||
let of_string syn s =
|
||||
match syn with
|
||||
| Jbuild when is_valid_jbuild s -> Some (A s)
|
||||
| Dune when is_valid_dune s -> Some (A s)
|
||||
| _ -> None
|
||||
|
||||
let of_string_exn syn s =
|
||||
match of_string syn s with
|
||||
| Some s -> s
|
||||
| None ->
|
||||
invalid_argf "'%s' is not a valid %s atom" s (string_of_syntax syn)
|
||||
|
||||
let to_string (A t) syntax =
|
||||
match syntax with
|
||||
| Jbuild -> t
|
||||
| Dune ->
|
||||
if is_valid_dune t then
|
||||
t
|
||||
else
|
||||
invalid_argf "Jbuild atom '%s' is not a valid dune atom" t
|
||||
|
||||
let of_int i = of_string_exn Dune (string_of_int i)
|
||||
let of_float x = of_string_exn Dune (string_of_float x)
|
||||
let of_bool x = of_string_exn Dune (string_of_bool x)
|
||||
let of_int64 i = of_string_exn Dune (Int64.to_string i)
|
||||
let of_digest d = of_string_exn Dune (Digest.to_hex d)
|
|
@ -0,0 +1,15 @@
|
|||
type t = private A of string [@@unboxed]
|
||||
|
||||
type syntax = Jbuild | Dune
|
||||
|
||||
val of_string : syntax -> string -> t option
|
||||
|
||||
val of_string_exn : syntax -> string -> t
|
||||
|
||||
val to_string : t -> syntax -> 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
|
|
@ -1,7 +1,3 @@
|
|||
module Atom : sig
|
||||
type t = A of string [@@unboxed]
|
||||
end
|
||||
|
||||
module Token : sig
|
||||
type t =
|
||||
| Atom of Atom.t
|
||||
|
|
|
@ -1,8 +1,4 @@
|
|||
{
|
||||
module Atom = struct
|
||||
type t = A of string [@@unboxed]
|
||||
end
|
||||
|
||||
module Token = struct
|
||||
type t =
|
||||
| Atom of Atom.t
|
||||
|
@ -128,7 +124,7 @@ and jbuild_atom acc start = parse
|
|||
error lexbuf "Internal error in the S-expression parser, \
|
||||
please report upstream.";
|
||||
lexbuf.lex_start_p <- start;
|
||||
Token.Atom (A acc)
|
||||
Token.Atom (Atom.of_string_exn Jbuild acc)
|
||||
}
|
||||
|
||||
and quoted_string mode = parse
|
||||
|
@ -248,7 +244,7 @@ and token = parse
|
|||
Quoted_string s
|
||||
}
|
||||
| atom_char_dune+ as s
|
||||
{ Token.Atom (A s) }
|
||||
{ Token.Atom (Atom.of_string_exn Dune s) }
|
||||
| eof
|
||||
{ Eof }
|
||||
|
||||
|
|
|
@ -10,34 +10,7 @@ module Bytes = struct
|
|||
UnlabeledBytes.blit_string src src_pos dst dst_pos len
|
||||
end
|
||||
|
||||
module Atom = struct
|
||||
type t = Lexer.Atom.t = A of string [@@unboxed]
|
||||
|
||||
let is_valid =
|
||||
let rec loop s i len =
|
||||
i = len ||
|
||||
match String.unsafe_get s i with
|
||||
| '"' | '(' | ')' | ';' | '\000'..'\032' | '\127'..'\255' -> false
|
||||
| _ -> loop s (i + 1) len
|
||||
in
|
||||
fun s ->
|
||||
let len = String.length s in
|
||||
len > 0 && loop s 0 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 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 to_string (A s) = s
|
||||
end
|
||||
module Atom = Atom
|
||||
|
||||
type t =
|
||||
| Atom of Atom.t
|
||||
|
@ -46,15 +19,14 @@ type t =
|
|||
|
||||
type sexp = t
|
||||
|
||||
let atom s =
|
||||
if Atom.is_valid s then Atom (A s)
|
||||
else invalid_arg "Usexp.atom"
|
||||
let atom s = Atom (Atom.of_string_exn Dune s)
|
||||
|
||||
let unsafe_atom_of_string s = Atom(A s)
|
||||
let unsafe_atom_of_string s = atom s
|
||||
|
||||
let atom_or_quoted_string s =
|
||||
if Atom.is_valid s then Atom (A s)
|
||||
else Quoted_string s
|
||||
match Atom.of_string Atom.Dune s with
|
||||
| None -> Quoted_string s
|
||||
| Some a -> Atom a
|
||||
|
||||
let quote_length s =
|
||||
let n = ref 0 in
|
||||
|
@ -117,13 +89,13 @@ let quoted s =
|
|||
Bytes.unsafe_to_string s'
|
||||
|
||||
let rec to_string = function
|
||||
| Atom (A s) -> s
|
||||
| Atom a -> Atom.to_string a Atom.Dune
|
||||
| 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 (A s) ->
|
||||
Format.pp_print_string ppf s
|
||||
| Atom s ->
|
||||
Format.pp_print_string ppf (Atom.to_string s Atom.Dune)
|
||||
| Quoted_string s ->
|
||||
Format.pp_print_string ppf (quoted s)
|
||||
| List [] ->
|
||||
|
@ -164,7 +136,7 @@ let pp_print_quoted_string ppf s =
|
|||
Format.pp_print_string ppf (quoted s)
|
||||
|
||||
let rec pp_split_strings ppf = function
|
||||
| Atom (A s) -> Format.pp_print_string ppf s
|
||||
| Atom s -> Format.pp_print_string ppf (Atom.to_string s Atom.Dune)
|
||||
| Quoted_string s -> pp_print_quoted_string ppf s
|
||||
| List [] ->
|
||||
Format.pp_print_string ppf "()"
|
||||
|
@ -249,8 +221,9 @@ module Ast = struct
|
|||
| List of Loc.t * t list
|
||||
|
||||
let atom_or_quoted_string loc s =
|
||||
if Atom.is_valid s then Atom (loc, A s)
|
||||
else Quoted_string (loc, s)
|
||||
match Atom.of_string Atom.Dune s with
|
||||
| None -> Quoted_string (loc, s)
|
||||
| Some a -> Atom (loc, a)
|
||||
|
||||
let loc (Atom (loc, _) | Quoted_string (loc, _) | List (loc, _)) = loc
|
||||
|
||||
|
|
|
@ -7,20 +7,19 @@ module Atom : sig
|
|||
(** Acceptable atoms are composed of chars in the range ['!' .. '~'] excluding
|
||||
[' ' '"' '(' ')' ';' '\\'], and must be nonempty. *)
|
||||
|
||||
val is_valid : string -> bool
|
||||
(** [is_valid s] checks that [s] respects the constraints to be an atom. *)
|
||||
type syntax = Jbuild | Dune
|
||||
|
||||
val of_string : string -> t
|
||||
(** Convert a string to an atom. If the string contains invalid
|
||||
characters, raise [Invalid_argument]. *)
|
||||
val of_string : syntax -> string -> t option
|
||||
|
||||
val of_string_exn : syntax -> string -> t
|
||||
|
||||
val to_string : t -> syntax -> 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
|
||||
|
|
|
@ -140,7 +140,7 @@ parse {|"$bar%foo%"|}
|
|||
|
||||
parse {|\%{foo}|}
|
||||
[%%expect{|
|
||||
- : parse_result = Same (Ok [\%{foo}])
|
||||
Exception: Invalid_argument "'\\%{foo}' is not a valid dune atom".
|
||||
|}]
|
||||
|
||||
parse {|\${foo}|}
|
||||
|
@ -150,15 +150,15 @@ parse {|\${foo}|}
|
|||
|
||||
parse {|\$bar%foo%|}
|
||||
[%%expect{|
|
||||
- : parse_result = Same (Ok [\$bar%foo%])
|
||||
Exception: Invalid_argument "'\\$bar%foo%' is not a valid dune atom".
|
||||
|}]
|
||||
|
||||
parse {|\$bar\%foo%|}
|
||||
[%%expect{|
|
||||
- : parse_result = Same (Ok [\$bar\%foo%])
|
||||
Exception: Invalid_argument "'\\$bar\\%foo%' is not a valid dune atom".
|
||||
|}]
|
||||
|
||||
parse {|\$bar\%foo%{bar}|}
|
||||
[%%expect{|
|
||||
- : parse_result = Same (Ok [\$bar\%foo%{bar}])
|
||||
Exception: Invalid_argument "'\\$bar\\%foo%{bar}' is not a valid dune atom".
|
||||
|}]
|
||||
|
|
|
@ -23,13 +23,15 @@ let () =
|
|||
| Atom _ -> true
|
||||
| _ -> false
|
||||
in
|
||||
if Usexp.Atom.is_valid s <> parser_recognizes_as_atom then begin
|
||||
let valid_dune_atom =
|
||||
Option.is_some (Usexp.Atom.of_string Dune s) in
|
||||
if valid_dune_atom <> parser_recognizes_as_atom then begin
|
||||
Printf.eprintf
|
||||
"Usexp.Atom.is_valid error:\n\
|
||||
- s = %S\n\
|
||||
- Usexp.Atom.is_valid s = %B\n\
|
||||
- parser_recognizes_as_atom = %B\n"
|
||||
s (Usexp.Atom.is_valid s) parser_recognizes_as_atom;
|
||||
s valid_dune_atom parser_recognizes_as_atom;
|
||||
exit 1
|
||||
end;
|
||||
if printed_as_atom && not parser_recognizes_as_atom then begin
|
||||
|
|
Loading…
Reference in New Issue