add pretty-json

Author: ar-nelson

show.sld

@@ -15,7 +15,8 @@
           radix precision decimal-sep decimal-align
           sign-rule comma-rule comma-sep word-separator?
           ambiguous-is-wide?)
-  (export pretty pretty-shared pretty-simply pretty-color)
+  (export pretty pretty-shared pretty-simply pretty-color
+          pretty-json pretty-json-color)
   (export columnar tabular
           boxed boxed/double boxed/ascii boxed/custom
           wrapped wrapped/list wrapped/char justified

show/block/json.sld

@@ -15,21 +15,21 @@
           (schemepunk syntax)
           (schemepunk list)
           (schemepunk json)
-          (schemepunk generator)
           (schemepunk term-colors)
           (schemepunk show span)
-          (schemepunk show block))
+          (schemepunk show block)
+          (schemepunk show block datum))
 
   (begin
-    (define json-color-object (make-parameter yellow))
-    (define json-color-object-key (make-parameter cyan))
-    (define json-color-array (make-parameter white))
-    (define json-color-string (make-parameter green))
-    (define json-color-number (make-parameter magenta))
-    (define json-color-true (make-parameter red))
-    (define json-color-false (make-parameter red))
-    (define json-color-null (make-parameter red))
-    (define json-color-error (make-parameter red))
+    (define json-color-object (make-parameter #f))
+    (define json-color-object-key (make-parameter #f))
+    (define json-color-array (make-parameter #f))
+    (define json-color-string (make-parameter #f))
+    (define json-color-number (make-parameter #f))
+    (define json-color-true (make-parameter #f))
+    (define json-color-false (make-parameter #f))
+    (define json-color-null (make-parameter #f))
+    (define json-color-error (make-parameter #f))
 
     (define (with-default-json-colors thunk)
       (parameterize ((json-color-object yellow)
@@ -101,6 +101,9 @@
         ('null
           (make-block
             (list (text-span "null" (json-color-null)))))
-        (else
+        (datum
           (make-block
-            (list (text-span "<NOT JSON>" (json-color-error)))))))))
+            (list (text-span "(NOT JSON:" (json-color-error))
+                  (whitespace-span))
+            (list (datum->block datum))
+            (list (text-span ")" (json-color-error)))))))))

show/debug.sld

@@ -1,23 +1,11 @@
 (define-library (schemepunk show debug)
   (export write-debug write-debug-json)
   (import (scheme base)
-          (schemepunk syntax)
-          (schemepunk generator)
-          (schemepunk show span)
-          (schemepunk show block)
-          (schemepunk show block datum)
-          (schemepunk show block json))
+          (schemepunk show base)
+          (schemepunk show pretty))
   (begin
     (define (write-debug datum)
-      (with-default-datum-colors (λ ()
-        (chain (datum->block datum)
-               (block->span-generator/indented)
-               (generator-for-each write-span))
-        (newline))))
+      (show #t (pretty-color datum) fl))
 
     (define (write-debug-json json)
-      (with-default-json-colors (λ ()
-        (chain (json->block json)
-               (block->span-generator/indented)
-               (generator-for-each write-span))
-        (newline))))))
+      (show #t (pretty-json-color json) fl))))

show/pretty.sld

@@ -1,12 +1,13 @@
 (define-library (schemepunk show pretty)
   (export pretty pretty-shared pretty-simply pretty-color
-          indent-size)
+          pretty-json pretty-json-color indent-size)
   (import (scheme base)
           (schemepunk syntax)
           (schemepunk show base)
           (schemepunk show span)
           (schemepunk show block)
-          (schemepunk show block datum))
+          (schemepunk show block datum)
+          (schemepunk show block json))
 
   (begin
     (define indent-size (make-state-variable "indent-size" 2))
@@ -46,4 +47,23 @@
               (datum->block obj)
               width
               string-width
+              indent-size))))))
+
+    (define (pretty-json json)
+      (fn (width string-width indent-size)
+        (span-generator->formatter
+          (block->span-generator/indented
+            (json->block json)
+            width
+            string-width
+            indent-size))))
+
+    (define (pretty-json-color json)
+      (fn (width string-width indent-size)
+        (span-generator->formatter
+          (with-default-json-colors (λ()
+            (block->span-generator/indented
+              (json->block json)
+              width
+              string-width
               indent-size))))))))