[ generalities ] Remove Format-based pretty printing

Author: bobatkey

coursework1-marking/main.ml

@@ -277,23 +277,23 @@ let print_err =
   | `Not_enough_solutions expected_json ->
      [p [txt "Your code does not produce enough solutions. The \
               following solution is not generated by your constraints:"]
-     ; code_bl (Generalities.Json.Printing.to_string expected_json)
+     ; code_bl (Generalities.Json.to_string expected_json)
      ]
   | `Too_many_solutions unwanted_json ->
      [p [txt "Your code produces too many solutions. The following \
               solution is generated by your constraints, but is not \
               required by the solution:"]
-     ; code_bl (Generalities.Json.Printing.to_string unwanted_json)
+     ; code_bl (Generalities.Json.to_string unwanted_json)
      ]
   | `Solution_mismatch (expected, submitted) ->
      [ p [txt "Your code produces solutions that are not required, and \
                misses solutions that are required. The following is an \
                example of a solution that your code should produce but \
                does not:"]
-     ; code_bl (Generalities.Json.Printing.to_string expected)
+     ; code_bl (Generalities.Json.to_string expected)
      ; p [txt "This is an example of a solution that you code produces \
                but should not:"]
-     ; code_bl (Generalities.Json.Printing.to_string submitted)
+     ; code_bl (Generalities.Json.to_string submitted)
      ]
 
 let seq_head seq = match seq () with
@@ -335,7 +335,7 @@ let mark_question submission (question_id, question_title, marks, solution) =
              None, Error
                      [ p [txt "The solutions generated by this code are:"]
                      ; code_bl (String.concat "\n"
-                                  (List.map Generalities.Json.Printing.to_string jsons))
+                                  (List.map Generalities.Json.to_string jsons))
                      ]
           | Error err ->
              Some 0, Error (print_err err)

generalities/json.ml

@@ -45,7 +45,7 @@ module P = struct
       |> Seq_ext.intersperse (comma ^^ break)
       |> concat
     in
-    (* maybe_flat *) (nest 2 (break ^^ body) ^^ break)
+    maybe_flat (nest 2 (break ^^ body) ^^ break)
 
   let rec to_document = function
     | JNull ->
@@ -67,65 +67,15 @@ module P = struct
             fields)
 end
 
-module Printing = struct
-  let pp_comma fmt () = Format.pp_print_string fmt ","
-
-  let rec to_string = function
-    | JString str -> Printf.sprintf "%S" str
-    | JBool b -> Printf.sprintf "%b" b
-    | JInt i -> string_of_int i
-    | JArray jsons ->
-       "[" ^ String.concat ", " (List.map to_string jsons) ^ "]"
-    | JNull -> "null"
-    | JObject obj ->
-       let field_to_string (nm, json) =
-         Printf.sprintf "%S: %s" nm (to_string json)
-       in
-       "{" ^ String.concat ", " (List.map field_to_string obj) ^ "}"
-
-  (* FIXME: move to a Utf8_string module *)
-  let json_escape fmt s =
-    let s = Utf8_string.of_string_unsafe s in
-    (* FIXME *)
-    let b = Buffer.create (Utf8_string.byte_length s + 4) in
-    let escape_char c =
-      if c = Uchar.of_char '"' then Buffer.add_char b '"'
-      else if c = Uchar.of_char '\\' then Buffer.add_char b '\\'
-      else if c = Uchar.of_char '\n' then Buffer.add_string b "\\n"
-      else if c = Uchar.of_char '\x0c' then Buffer.add_string b "\\f"
-      else if c = Uchar.of_char '\t' then Buffer.add_string b "\\t"
-      else if c = Uchar.of_char '\r' then Buffer.add_string b "\\r"
-      else if c = Uchar.of_char '\b' then Buffer.add_string b "\\b"
-      else Buffer.add_utf_8_uchar b c
-    in
-    Utf8_string.iter escape_char s;
-    Format.pp_print_string fmt (Buffer.contents b)
-
-  let pp_string fmt s =
-    Format.fprintf fmt "\"%a\"" json_escape s
-  let pp_delim =
-    Format.pp_print_string
-
-  let rec pp fmt = function
-    | JString s -> pp_string fmt s
-    | JBool true -> Format.pp_print_string fmt "true"
-    | JBool false -> Format.pp_print_string fmt "false"
-    | JInt i -> Format.pp_print_int fmt i
-    (*  | Float f -> Format.pp_print_float fmt f (* FIXME: proper format *) *)
-    | JNull -> Format.pp_print_string fmt "null"
-    | JArray [] ->
-       Format.pp_print_string fmt "[]"
-    | JArray elems ->
-       Format.fprintf fmt "%a@,@[<v2>  %a@]@,%a"
-         pp_delim "["
-         (Format.pp_print_list ~pp_sep:pp_comma pp) elems
-         pp_delim "]"
-    | JObject [] ->
-       Format.pp_print_string fmt "{}"
-    | JObject fields ->
-        Format.fprintf fmt "%a@,@[<v2>  %a@]@,%a" pp_delim "{"
-          (Format.pp_print_list ~pp_sep:pp_comma pp_field)
-          fields pp_delim "}"
-
-  and pp_field fmt (nm, json) = Format.fprintf fmt "%a: %a" pp_string nm pp json
-end
+let rec to_string = function
+  | JString str -> Printf.sprintf "%S" str
+  | JBool b -> Printf.sprintf "%b" b
+  | JInt i -> string_of_int i
+  | JArray jsons ->
+     "[" ^ String.concat ", " (List.map to_string jsons) ^ "]"
+  | JNull -> "null"
+  | JObject obj ->
+     let field_to_string (nm, json) =
+       Printf.sprintf "%S: %s" nm (to_string json)
+     in
+     "{" ^ String.concat ", " (List.map field_to_string obj) ^ "}"

generalities/pretty.ml

@@ -93,14 +93,26 @@ let group doc =
 (******************************************************************************)
 (* Output of documents *)
 
-let emit =
-  print_string
-let emit_newline =
-  print_newline
-let emit_spaces n =
-  print_string (String.make n ' ')
-
-let output ?(width=80) document =
+type output =
+  { emit         : string -> unit
+  ; emit_newline : unit -> unit
+  ; emit_spaces  : int -> unit
+  }
+
+let output_of_channel ch =
+  { emit         = Out_channel.output_string ch
+  ; emit_newline = (fun () -> Out_channel.output_char ch '\n')
+  ; emit_spaces  = (fun n -> Out_channel.output_string ch (String.make n ' '))
+  }
+
+let output_of_buffer b =
+  { emit         = Buffer.add_string b
+  ; emit_newline = (fun () -> Buffer.add_string b "\n")
+  ; emit_spaces  = (fun n -> Buffer.add_string b (String.make n ' '))
+  }
+
+let output ?(width=80) output document =
+  let { emit; emit_newline; emit_spaces } = output in
   let rec flat = function
     | Empty | AlignSpaces _ ->
        ()
@@ -139,3 +151,16 @@ let output ?(width=80) document =
   in
   let _ = process 0 0 0 document.doc in
   ()
+
+let print ?width document =
+  let o = output_of_channel Out_channel.stdout in
+  output ?width o document
+
+let to_buffer ?width b document =
+  let o = output_of_buffer b in
+  output ?width o document
+
+let to_string ?width document =
+  let b = Buffer.create 8192 in
+  to_buffer ?width b document;
+  Buffer.contents b

generalities/pretty.mli

@@ -21,4 +21,8 @@ val break : document
    3. flat output
    4. typed document constructor combinators
  *)
-val output : ?width:int -> document -> unit
+val print : ?width:int -> document -> unit
+
+val to_string : ?width:int -> document -> string
+
+val to_buffer : ?width:int -> Buffer.t -> document -> unit

slakemoth/bin/main.ml

@@ -6,7 +6,7 @@ let handle_errors = function
   | Ok () ->
      exit 0
   | Error (`Parse err) ->
-     Format.eprintf "ERROR: %s\n" (Parser_util.Driver.string_of_error err);
+     Printf.eprintf "ERROR: %s\n" (Parser_util.Driver.string_of_error err);
      exit 1
   | Error (`Type_error (location, msg)) ->
      let msg = Printf.sprintf "Problem at %a: %s"
@@ -26,7 +26,8 @@ let execute filename =
   commands
   |> List.to_seq
   |> Seq.concat_map Evaluator.execute_command
-  |> Seq.iter (Format.printf "@[<v0>%a@]@\n" Json.Printing.pp);
+  |> Seq.iter (fun json -> Pretty.print (Json.P.to_document json);
+                           print_newline ());
   Result.ok ()
 
 let pretty_print filename =

slakemoth/widget/slakemoth_widget.ml

@@ -4,6 +4,7 @@ let component configuration =
 
       module Ast = Slakemoth.Ast
       open Slakemoth.Environment
+      open Generalities
 
       type state = {
           input : string;
@@ -150,13 +151,12 @@ let component configuration =
            (match state.parse_result with
             | Ok commands ->
                let b = Buffer.create 8192 in
-               let fmt = Format.formatter_of_buffer b in
                commands
                |> List.to_seq
                |> Seq.concat_map Slakemoth.Evaluator.execute_command
-               |> Seq.iter (Format.fprintf fmt "@[<v0>%a@]@\n"
-                              Generalities.Json.Printing.pp);
-               Format.pp_print_flush fmt ();
+               |> Seq.iter (fun json ->
+                      Pretty.to_buffer ~width:50 b (Json.P.to_document json);
+                      Buffer.add_string b "\n");
                { state with fresh = true; output = `String (Buffer.contents b) }
             | Error _ ->
                (* Button should be disabled to prevent this *)