Always output JSON compliant floats (if possible)

Leonidas-from-XIV · Leonidas-from-XIV · commit aa1a43fbb946 · 2025-03-31T10:55:35.000+02:00
This disables the `std` argument but keeps it and the functions to not
create additional unnecessary API breakage.
diff --git a/CHANGES.md b/CHANGES.md
@@ -4,6 +4,12 @@
 
 ### Changed
 
+- Floats are now always output to JSON in a standard-conformant way or not at
+  all (raising an exception). This makes the `std` variants of functions
+  identical to the non-`std` variants and the `std` arguments have no effect.
+  Users are encouraged to switch to the non-`std` affixed variants, the others
+  will be deprecated in the future.  (#184, @Leonidas-from-XIV)
+
 ### Deprecated
 
 ### Fixed
diff --git a/lib/prettyprint.ml b/lib/prettyprint.ml
@@ -66,7 +66,7 @@ let is_atom_list l =
          bar
        ]
 *)
-let rec format ~inside_box std (out:Format.formatter) (x:t) : unit =
+let rec format ~inside_box (out : Format.formatter) (x : t) : unit =
   match x with
     | `Null -> Format.pp_print_string out "null"
     | `Bool x -> Format.pp_print_bool out x
@@ -75,11 +75,7 @@ let rec format ~inside_box std (out:Format.formatter) (x:t) : unit =
 #endif
 #ifdef FLOAT
     | `Float x ->
-        let s =
-          if std then std_json_string_of_float x
-          else json_string_of_float x
-        in
-        Format.pp_print_string out s
+        Format.pp_print_string out (json_string_of_float x)
 #endif
 #ifdef STRING
     | `String s -> Format.pp_print_string out (json_string_of_string s)
@@ -99,24 +95,25 @@ let rec format ~inside_box std (out:Format.formatter) (x:t) : unit =
       if is_atom_list l then
         (* use line wrapping like we would do for a paragraph of text *)
         Format.fprintf out "[@;<1 0>@[<hov>%a@]@;<1 -2>]"
-          (pp_list "," (format ~inside_box:false std)) l
+          (pp_list "," (format ~inside_box:false)) l
       else
         (* print the elements horizontally if they fit on the line,
            otherwise print them in a column *)
         Format.fprintf out "[@;<1 0>@[<hv>%a@]@;<1 -2>]"
-          (pp_list "," (format ~inside_box:false std)) l;
+          (pp_list "," (format ~inside_box:false)) l;
       if not inside_box then Format.fprintf out "@]";
     | `Assoc [] -> Format.pp_print_string out "{}"
     | `Assoc l ->
       if not inside_box then Format.fprintf out "@[<hv2>";
-      Format.fprintf out "{@;<1 0>%a@;<1 -2>}" (pp_list "," (format_field std)) l;
+      Format.fprintf out "{@;<1 0>%a@;<1 -2>}" (pp_list "," (format_field)) l;
       if not inside_box then Format.fprintf out "@]";
 
-and format_field std out (name, x) =
-  Format.fprintf out "@[<hv2>%s: %a@]" (json_string_of_string name) (format ~inside_box:true std) x
+and format_field out (name, x) =
+  Format.fprintf out "@[<hv2>%s: %a@]" (json_string_of_string name) (format ~inside_box:true) x
 
-let pp ?(std = false) out x =
-  Format.fprintf out "@[<hv2>%a@]" (format ~inside_box:true std) (x :> t)
+(* [std] argument to be deprecated *)
+let pp ?(std = true) out x =
+  Format.fprintf out "@[<hv2>%a@]" (format ~inside_box:true) (x :> t)
 
 let to_string ?std x =
   Format.asprintf "%a" (pp ?std) x
diff --git a/lib/write.ml b/lib/write.ml
@@ -144,23 +144,12 @@ let write_normal_float_prec significant_figures ob x =
   if float_needs_period s then
     Buffer.add_string ob ".0"
 
-(* used by atdgen *)
-let write_float_prec significant_figures ob x =
-  match classify_float x with
-    FP_nan ->
-      Buffer.add_string ob "NaN"
-  | FP_infinite ->
-      Buffer.add_string ob (if x > 0. then "Infinity" else "-Infinity")
-  | _ ->
-      write_normal_float_prec significant_figures ob x
-
 let json_string_of_float x =
   let ob = Buffer.create 20 in
   write_float ob x;
   Buffer.contents ob
 
-
-let write_std_float ob x =
+let write_float ob x =
   match classify_float x with
     FP_nan ->
       Common.json_error "NaN value not allowed in standard JSON"
@@ -180,8 +169,11 @@ let write_std_float ob x =
       if float_needs_period s then
         Buffer.add_string ob ".0"
 
+(* to be deprecated in a future release *)
+let write_std_float = write_float
+
 (* used by atdgen *)
-let write_std_float_prec significant_figures ob x =
+let write_float_prec significant_figures ob x =
   match classify_float x with
     FP_nan ->
       Common.json_error "NaN value not allowed in standard JSON"
@@ -194,11 +186,7 @@ let write_std_float_prec significant_figures ob x =
   | _ ->
       write_normal_float_prec significant_figures ob x
 
-let std_json_string_of_float x =
-  let ob = Buffer.create 20 in
-  write_std_float ob x;
-  Buffer.contents ob
-
+let write_std_float_prec = write_float_prec
 
 let write_intlit = Buffer.add_string
 let write_floatlit = Buffer.add_string
@@ -262,51 +250,11 @@ and write_list ob l =
 
 let write_t = write_json
 
-let rec write_std_json ob (x : t) =
-  match x with
-      `Null -> write_null ob ()
-    | `Bool b -> write_bool ob b
-#ifdef INT
-    | `Int i -> write_int ob i
-#endif
-#ifdef INTLIT
-    | `Intlit s -> Buffer.add_string ob s
-#endif
-#ifdef FLOAT
-    | `Float f -> write_std_float ob f
-#endif
-#ifdef FLOATLIT
-    | `Floatlit s -> Buffer.add_string ob s
-#endif
-#ifdef STRING
-    | `String s -> write_string ob s
-#endif
-#ifdef STRINGLIT
-    | `Stringlit s -> Buffer.add_string ob s
-#endif
-    | `Assoc l -> write_std_assoc ob l
-    | `List l -> write_std_list ob l
+let write_std_json = write_json
 
-and write_std_assoc ob l =
-  let f_elt ob (s, x) =
-    write_string ob s;
-    Buffer.add_char ob ':';
-    write_std_json ob x
-  in
-  Buffer.add_char ob '{';
-  iter2 f_elt f_sep ob l;
-  Buffer.add_char ob '}';
-
-and write_std_list ob l =
-  Buffer.add_char ob '[';
-  iter2 write_std_json f_sep ob l;
-  Buffer.add_char ob ']'
-
-let to_buffer ?(suf = "") ?(std = false) ob x =
-  if std then
-    write_std_json ob x
-  else
-    write_json ob x;
+(* std argument is going to be deprecated *)
+let to_buffer ?(suf = "") ?(std = true) ob x =
+  write_json ob x;
   Buffer.add_string ob suf
 
 let to_string ?buf ?(len = 256) ?(suf = "") ?std x =
