diff --git a/src/dune_project.ml b/src/dune_project.ml index 31878120..a24003ab 100644 --- a/src/dune_project.ml +++ b/src/dune_project.ml @@ -149,7 +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_exn Sexp.Atom.Dune ver)) in + (Atom (ver_loc, Sexp.Atom.of_string ver)) in match Hashtbl.find langs name with | None -> Loc.fail name_loc "Unknown language %S.%s" name diff --git a/src/loc.ml b/src/loc.ml index f1b78fba..28d7a1dc 100644 --- a/src/loc.ml +++ b/src/loc.ml @@ -11,8 +11,7 @@ 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_exn Atom.Dune n); v])) + List (List.map l ~f:(fun (n, v) -> List [Atom(Atom.of_string n); v])) let sexp_of_position_no_file (p : Lexing.position) = record diff --git a/src/stdune/sexp.ml b/src/stdune/sexp.ml index a4636715..694452e0 100644 --- a/src/stdune/sexp.ml +++ b/src/stdune/sexp.ml @@ -34,8 +34,7 @@ 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_exn Usexp.Atom.Dune n); v])) + List (List.map l ~f:(fun (n, v) -> List [Atom(Atom.of_string n); v])) let string_hashtbl f h = string_map f (Hashtbl.foldi h ~init:String.Map.empty ~f:(fun key data acc -> @@ -55,7 +54,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_exn Atom.Dune k); v]))) + Option.map v ~f:(fun v -> List[Atom (Atom.of_string k); v]))) let unknown _ = unsafe_atom_of_string "" end diff --git a/src/usexp/atom.ml b/src/usexp/atom.ml index c53eaa97..3034ff73 100644 --- a/src/usexp/atom.ml +++ b/src/usexp/atom.ml @@ -4,10 +4,6 @@ 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 || @@ -31,29 +27,23 @@ let (is_valid_jbuild, is_valid_dune) = 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 of_string s = A s let to_string (A t) syntax = match syntax with - | Jbuild -> t + | Jbuild -> + if is_valid_jbuild t then + t + else + invalid_argf "Dune atom '%s' cannot be printed" t | Dune -> if is_valid_dune t then t else - invalid_argf "Jbuild atom '%s' is not a valid dune atom" t + invalid_argf "Jbuild atom '%s' cannot be printed" 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) +let of_int i = of_string (string_of_int i) +let of_float x = of_string (string_of_float x) +let of_bool x = of_string (string_of_bool x) +let of_digest d = of_string (Digest.to_hex d) +let of_int64 i = of_string (Int64.to_string i) diff --git a/src/usexp/atom.mli b/src/usexp/atom.mli index 40bd6658..2036a159 100644 --- a/src/usexp/atom.mli +++ b/src/usexp/atom.mli @@ -2,9 +2,9 @@ type t = private A of string [@@unboxed] type syntax = Jbuild | Dune -val of_string : syntax -> string -> t option +val is_valid_dune : string -> bool -val of_string_exn : syntax -> string -> t +val of_string : string -> t val to_string : t -> syntax -> string diff --git a/src/usexp/lexer.mll b/src/usexp/lexer.mll index ef072f06..2c9098b0 100644 --- a/src/usexp/lexer.mll +++ b/src/usexp/lexer.mll @@ -77,7 +77,7 @@ let hexdigit = ['0'-'9' 'a'-'f' 'A'-'F'] let atom_char_jbuild = [^ ';' '(' ')' '"' ' ' '\t' '\r' '\n' '\012'] let atom_char_dune = - [^ ';' '(' ')' '"' '\000'-'\032' '\127'-'\255'] + [^ '%' ';' '(' ')' '"' '\000'-'\032' '\127'-'\255'] (* rule for jbuild files *) rule jbuild_token = parse @@ -124,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 (Atom.of_string_exn Jbuild acc) + Token.Atom (Atom.of_string acc) } and quoted_string mode = parse @@ -244,7 +244,8 @@ and token = parse Quoted_string s } | atom_char_dune+ as s - { Token.Atom (Atom.of_string_exn Dune s) } + { Token.Atom (Atom.of_string s) } + | _ as c { error lexbuf (Printf.sprintf "Invalid atom character '%c'" c) } | eof { Eof } diff --git a/src/usexp/usexp.ml b/src/usexp/usexp.ml index 0252bc66..ce9fca58 100644 --- a/src/usexp/usexp.ml +++ b/src/usexp/usexp.ml @@ -19,14 +19,15 @@ type t = type sexp = t -let atom s = Atom (Atom.of_string_exn Dune s) +let atom s = Atom (Atom.of_string s) let unsafe_atom_of_string s = atom s let atom_or_quoted_string s = - match Atom.of_string Atom.Dune s with - | None -> Quoted_string s - | Some a -> Atom a + if Atom.is_valid_dune s then + Atom (Atom.of_string s) + else + Quoted_string s let quote_length s = let n = ref 0 in @@ -221,9 +222,10 @@ module Ast = struct | List of Loc.t * t list let atom_or_quoted_string loc s = - match Atom.of_string Atom.Dune s with - | None -> Quoted_string (loc, s) - | Some a -> Atom (loc, a) + match atom_or_quoted_string s with + | Atom a -> Atom (loc, a) + | Quoted_string s -> Quoted_string (loc, s) + | List _ -> assert false let loc (Atom (loc, _) | Quoted_string (loc, _) | List (loc, _)) = loc diff --git a/src/usexp/usexp.mli b/src/usexp/usexp.mli index 781625e0..398ab39a 100644 --- a/src/usexp/usexp.mli +++ b/src/usexp/usexp.mli @@ -9,9 +9,9 @@ module Atom : sig type syntax = Jbuild | Dune - val of_string : syntax -> string -> t option + val is_valid_dune : string -> bool - val of_string_exn : syntax -> string -> t + val of_string : string -> t val to_string : t -> syntax -> string diff --git a/test/unit-tests/sexp.mlt b/test/unit-tests/sexp.mlt index 821f4488..880f372b 100644 --- a/test/unit-tests/sexp.mlt +++ b/test/unit-tests/sexp.mlt @@ -52,8 +52,9 @@ let parse s = let f ~lexer = try Ok (Sexp.parse_string ~fname:"" ~mode:Many ~lexer s) - with Sexp.Parse_error e -> - Error (Sexp.Parse_error.message e) + with + | Sexp.Parse_error e -> Error (Sexp.Parse_error.message e) + | Invalid_argument e -> Error e in let jbuild = f ~lexer:Sexp.Lexer.jbuild_token in let dune = f ~lexer:Sexp.Lexer.token in @@ -140,7 +141,12 @@ parse {|"$bar%foo%"|} parse {|\%{foo}|} [%%expect{| -Exception: Invalid_argument "'\\%{foo}' is not a valid dune atom". +- : parse_result = +Different + {jbuild = + Ok + []; + dune = Error "Invalid atom character '%'"} |}] parse {|\${foo}|} @@ -150,15 +156,30 @@ parse {|\${foo}|} parse {|\$bar%foo%|} [%%expect{| -Exception: Invalid_argument "'\\$bar%foo%' is not a valid dune atom". +- : parse_result = +Different + {jbuild = + Ok + []; + dune = Error "Invalid atom character '%'"} |}] parse {|\$bar\%foo%|} [%%expect{| -Exception: Invalid_argument "'\\$bar\\%foo%' is not a valid dune atom". +- : parse_result = +Different + {jbuild = + Ok + []; + dune = Error "Invalid atom character '%'"} |}] parse {|\$bar\%foo%{bar}|} [%%expect{| -Exception: Invalid_argument "'\\$bar\\%foo%{bar}' is not a valid dune atom". +- : parse_result = +Different + {jbuild = + Ok + []; + dune = Error "Invalid atom character '%'"} |}] diff --git a/test/unit-tests/sexp_tests.ml b/test/unit-tests/sexp_tests.ml index 2d4e3fbf..2d733007 100644 --- a/test/unit-tests/sexp_tests.ml +++ b/test/unit-tests/sexp_tests.ml @@ -23,8 +23,7 @@ let () = | Atom _ -> true | _ -> false in - let valid_dune_atom = - Option.is_some (Usexp.Atom.of_string Dune s) in + let valid_dune_atom = Usexp.Atom.is_valid_dune s in if valid_dune_atom <> parser_recognizes_as_atom then begin Printf.eprintf "Usexp.Atom.is_valid error:\n\