srfi 166

3 files changed, 122 insertions, 20 deletions

diff --git a/README.md b/README.md
index 7a9d06f..366c943 100644
--- a/README.md
+++ b/README.md
@@ -30,6 +30,7 @@
 * SRFI 133: Vector Library (R7RS-compatible)
 * SRFI 151: Bitwise Operations
 * SRFI 157: Continuation marks
+* SRFI 166: Monadic Formatting
 * SRFI 176: Version flag
 * SRFI 181: Custom ports (including transcoded ports)
 * SRFI 192: Port Positioning
diff --git a/src/foment.hpp b/src/foment.hpp
index b9ebb21..ae417b2 100644
--- a/src/foment.hpp
+++ b/src/foment.hpp
@@ -8,13 +8,13 @@ To Do:
 -- Bytevectors: R6RS (rnrs bytevectors) as (scheme bytevector) (note singular form)
 -- SRFI 129: Titlecase Procedures
 -- SRFI 154: First-class dynamic extents
--- SRFI 166: Monadic Formatting
 -- SRFI 195: Multiple-value boxes
 -- SRIF 207: String-notated bytevectors
 
 -- IO: FAlive, EnterWait, and LeaveWait
 -- Allow GC on nested executions
--- SRFI 193: Command line: normalize paths
+-- SRFI 193: normalize paths
+-- SRFI 166: pretty print
 
 -- Benchmarks
 --- http://ecraven.github.io/r7rs-benchmarks/benchmark.html
diff --git a/src/srfi-166.scm b/src/srfi-166.scm
index a7cd274..b30388f 100644
--- a/src/srfi-166.scm
+++ b/src/srfi-166.scm
@@ -35,10 +35,10 @@
         fitted
         fitted/right
         fitted/both
-        ;pretty
-        ;pretty-shared
-        ;pretty-simply
-        ;pretty-with-color
+        pretty
+        pretty-shared
+        pretty-simply
+        (rename pretty pretty-with-color)
         columnar
         tabular
         wrapped
@@ -153,11 +153,11 @@
         (define (written obj)
             (fn (writer) (writer obj)))
         (define (written-default obj)
-            (%write obj (find-shared-objects obj #f)))
+            (%written %write obj (find-shared-objects obj #f)))
         (define (written-shared obj)
-            (%write obj (find-shared-objects obj #t)))
+            (%written %write obj (find-shared-objects obj #t)))
         (define (written-simply obj)
-            (%write obj #f))
+            (%written %write obj #f))
         (define (find-shared-objects obj all)
             (define (find-shared obj all shared)
                 (if (or (pair? obj) (vector? obj))
@@ -175,15 +175,18 @@
             (let ((shared (make-eq-hash-table)))
                 (find-shared obj all shared)
                 shared))
-        (define (%write obj shared)
+        (define (shared-object? obj shared)
+            (let ((val (if shared (%hash-table-ref shared obj 0) 0)))
+                (or (box? val) (> val 1))))
+        (define (%written write obj shared)
             (let ((write-radix (case (radix) ((2 8 10 16) (radix)) (else 10))))
                 (with ((radix write-radix)
                         (precision (if (= write-radix 10) (precision) #f))
                         (sign-rule #f)
                         (comma-rule #f)
                         (decimal-sep #\.))
-                    (%write-object obj shared (box 0)))))
-        (define (%write-object obj shared count)
+                    (write obj shared (box 0)))))
+        (define (%write obj shared count)
             (define (%write-number num)
                 (each
                     (if (exact? num)
@@ -194,23 +197,20 @@
                             (else ""))
                         "")
                     (numeric num)))
-            (define (shared-object? obj shared)
-                (let ((val (if shared (%hash-table-ref shared obj 0) 0)))
-                    (or (box? val) (> val 1))))
             (define (%write-list lst shared count)
                 (cond
                     ((null? lst) ")")
                     ((and (pair? lst) (not (shared-object? lst shared)))
-                        (each " " (%write-object (car lst) shared count)
+                        (each " " (%write (car lst) shared count)
                                 (fn () (%write-list (cdr lst) shared count))))
-                    (else (each " . " (%write-object lst shared count) ")"))))
+                    (else (each " . " (%write lst shared count) ")"))))
             (define (%write-vector vec idx shared count)
                 (cond
                     ((= idx (vector-length vec)) ")")
                     (else
                         (each
                             (if (> idx 0) " " nothing)
-                            (%write-object (vector-ref obj idx) shared count)
+                            (%write (vector-ref obj idx) shared count)
                             (fn () (%write-vector vec (+ idx 1) shared count))))))
             (let ((val (if shared (%hash-table-ref shared obj 0) 0)))
                 (if (box? val)
@@ -225,7 +225,7 @@
                         (cond
                             ((number? obj) (%write-number obj))
                             ((pair? obj)
-                                (each "(" (%write-object (car obj) shared count)
+                                (each "(" (%write (car obj) shared count)
                                         (fn () (%write-list (cdr obj) shared count))))
                             ((vector? obj) (each "#(" (%write-vector obj 0 shared count)))
                             (else
@@ -671,7 +671,14 @@
             (padded/right width (trimmed/right width (each-in-list fmts))))
         (define (fitted/both width . fmts)
             (padded/both width (trimmed/both width (each-in-list fmts))))
-
+        (define (pretty obj)
+            (%written %pretty obj (find-shared-objects obj #f)))
+        (define (pretty-shared obj)
+            (%written %pretty obj (find-shared-objects obj #t)))
+        (define (pretty-simply obj)
+            (%written %pretty obj #f))
+        (define (%pretty obj shared count)
+            (%write obj shared count))
         (define (string-split str ch)
             (define (split idx)
                 (if (= idx (string-length str))
@@ -1241,3 +1248,97 @@
         (define word-separator? (%make-state-variable char-whitespace? #t)) ; check for procedure
         )
     )
+
+(define-library (srfi 166 base)
+    (import (srfi 166))
+    (export
+        show
+        displayed
+        written
+        written-shared
+        written-simply
+        escaped
+        maybe-escaped
+        numeric
+        numeric/comma
+        numeric/si
+        numeric/fitted
+        nl
+        fl
+        space-to
+        tab-to
+        nothing
+        each
+        each-in-list
+        joined
+        joined/prefix
+        joined/suffix
+        joined/last
+        joined/dot
+        joined/range
+        padded
+        padded/right
+        padded/both
+        trimmed
+        trimmed/right
+        trimmed/both
+        trimmed/lazy
+        fitted
+        fitted/right
+        fitted/both
+        fn
+        with
+        with!
+        forked
+        call-with-output
+        make-state-variable
+        port
+        row
+        col
+        width
+        output
+        output-default
+        writer
+        string-width
+        substring/width
+        substring/preserve
+        pad-char
+        ellipsis
+        radix
+        precision
+        decimal-sep
+        decimal-align
+        sign-rule
+        comma-rule
+        comma-sep
+        word-separator?
+        ))
+
+(define-library (srfi 166 pretty)
+    (import (srfi 166))
+    (export
+        pretty
+        pretty-shared
+        pretty-simply
+        pretty-with-color)
+    )
+
+(define-library (srfi 166 columnar)
+    (import (srfi 166))
+    (export
+        columnar
+        tabular
+        wrapped
+        wrapped/list
+        wrapped/char
+        justified
+        from-file
+        line-numbers)
+    )
+
+(define-library (srfi 166 unicode)
+    (import (srfi 166))
+    (export
+        upcased
+        downcased)
+    )