making (chibi show) an alias of (srfi 166)

lib/chibi/show-test.sld

@@ -734,7 +734,7 @@ def | 6
       (test "\x1B;[31mred\x1B;[34mblue\x1B;[31mred\x1B;[0m"
           (show #f (as-red "red" (as-blue "blue") "red")))
       (test "\x1b;[31m1234567\x1b;[0m col: 7"
-            (show #f (as-unicode (as-red "1234567") (fn ((col)) (each " col: " col)))))
+            (show #f (as-unicode (as-red "1234567") (fn (col) (each " col: " col)))))
 
       ;; unicode
       (test "〜日本語〜"

lib/chibi/show.sld

@@ -1,14 +1,2 @@
 
-(define-library (chibi show)
+(define-library (chibi show) (alias-for (srfi 166)))
-  (export
-   show fn forked with with! each each-in-list call-with-output
-   displayed written written-shared written-simply
-   numeric numeric/comma numeric/si numeric/fitted
-   nothing nl fl space-to tab-to escaped maybe-escaped
-   padded padded/left padded/right padded/both
-   trimmed trimmed/left trimmed/right trimmed/both trimmed/lazy
-   fitted fitted/left fitted/right fitted/both
-   joined joined/prefix joined/suffix joined/last joined/dot joined/range)
-  (import (scheme base) (scheme char) (scheme write)
-          (chibi show base))
-  (include "show/show.scm"))

lib/chibi/show/base.sld

@@ -1,32 +1,2 @@
 
-(define-library (chibi show base)
+(define-library (chibi show base) (alias-for (srfi 166 base)))
-  (export
-   show fn forked with with! each each-in-list call-with-output
-   displayed written written-shared written-simply numeric nothing
-   escaped maybe-escaped numeric/si numeric/fitted numeric/comma
-   ;; internal
-   output-default extract-shared-objects write-to-string write-with-shares
-   call-with-shared-ref call-with-shared-ref/cdr)
-  (import (scheme base) (scheme write) (scheme complex) (scheme inexact)
-          (srfi 1) (srfi 69) (chibi string) (chibi monad environment)
-          (chibi show shared))
-  (cond-expand
-   (chibi
-    (import (only (chibi) let-optionals*)))
-   (else
-    (begin
-      (define-syntax let-optionals*
-        (syntax-rules ()
-          ((let-optionals* opt-ls () . body)
-           (begin . body))
-          ((let-optionals* (op . args) vars . body)
-           (let ((tmp (op . args)))
-             (let-optionals* tmp vars . body)))
-          ((let-optionals* tmp ((var default) . rest) . body)
-           (let ((var (if (pair? tmp) (car tmp) default))
-                 (tmp2 (if (pair? tmp) (cdr tmp) '())))
-             (let-optionals* tmp2 rest . body)))
-          ((let-optionals* tmp tail . body)
-           (let ((tail tmp)) . body)))))))
-  (include "base.scm")
-  (include "write.scm"))

lib/chibi/show/c.scm

@@ -2,10 +2,24 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; additional state information
 
+(define-syntax define-state-variables
+  (syntax-rules ()
+    ((define-state-variables var ...)
+     (begin
+       (define var
+         (make-computation-environment-variable 'var #f #f))
+       ...))))
+
+(define-state-variables
+  expression? in-cond? in-macro? return? non-spaced-ops?
+  braceless-bodies? newline-before-brace? no-wrap? macro-vars
+  expr-writer switch-indent-space indent-space
+  indent default-type dot op)
+
 (define (c-in-expr proc) (with ((expression? #t)) (c-expr proc)))
 (define (c-in-stmt proc) (with ((expression? #f)) (c-expr proc)))
 (define (c-in-test proc) (with ((in-cond? #t)) (c-in-expr proc)))
-(define (c-with-op op proc) (with ((op op)) proc))
+(define (c-with-op new-op proc) (with ((op new-op)) proc))
 
 (define nl-str (call-with-output-string newline))
 (define (make-nl-space n) (string-append nl-str (make-string n #\space)))
@@ -26,6 +40,11 @@
 (define (write-to-string x)
   (call-with-output-string (lambda (out) (write x out))))
 
+(define (string-find/index str pred i)
+  (string-cursor->index
+   str
+   (string-find str pred (string-index->cursor str i))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; be smart about operator precedence
 
@@ -76,9 +95,9 @@
   (each "(" x ")"))
 
 (define (c-maybe-paren x-op x)
-  (fn (op)
+  (fn ((orig-op op))
     (let ((x (with ((op x-op)) x)))
-      (if (c-op<= op x-op)
+      (if (c-op<= orig-op x-op)
           (c-paren x)
           x))))
 
@@ -244,6 +263,42 @@
    (else
     (c-literal x))))
 
+(define (try-fitted2 proc fail)
+  (fn (width (orig-output output))
+    (let ((out (open-output-string)))
+      (call-with-current-continuation
+       (lambda (abort)
+         ;; Modify output to accumulate to an output string port,
+         ;; and escape immediately with failure if we exceed the
+         ;; column width.
+         (define (output* str)
+           (fn (col)
+             (let lp ((i 0) (col col))
+               (let ((nli (string-find/index str #\newline i))
+                     (len (string-length str)))
+                 (if (< nli len)
+                     (if (> (+ (- nli i) col) width)
+                         (abort fail)
+                         (lp (+ nli 1) 0))
+                     (let ((col (+ (- len i) col)))
+                       (cond
+                        ((> col width)
+                         (abort fail))
+                        (else
+                         (output-default str)))))))))
+         (forked
+          (with ((output output*)
+                 (port out))
+            proc)
+          ;; fitted successfully
+          (fn () (orig-output (get-output-string out)))))))))
+
+(define (try-fitted proc . fail)
+  (let lp ((proc proc) (ls fail))
+    (if (null? ls)
+        proc
+        (try-fitted2 proc (lp (car ls) (cdr ls))))))
+
 (define (c-apply ls)
   (c-wrap-stmt
    (with ((op 'comma))
@@ -261,7 +316,7 @@
                     (joined c-expr (cdr ls) sep))))))))))))
 
 (define (c-expr x)
-  (fn (gen) ((or gen c-expr/sexp) x)))
+  (fn (expr-writer) ((or expr-writer c-expr/sexp) x)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; comments, with Emacs-friendly escaping of nested comments
@@ -291,33 +346,32 @@
              (lp (string-cursor-next str j))))))))))
 
 (define (c-comment . args)
-  (each "/*" (fn (output)
+  (each "/*" (fn ((orig-output output))
-               (with ((output (make-comment-writer output)))
+               (with ((output (make-comment-writer orig-output)))
                  (each-in-list args)))
         "*/"))
 
 (define (make-block-comment-writer)
   (lambda (str)
-    (fn (col output)
+    (fn (col (orig-output output))
-      (with ((output (make-comment-writer output)))
+      (with ((output (make-comment-writer orig-output)))
         (let ((end (string-cursor-end str))
               (indent (string-append (make-nl-space (+ col 1)) "* ")))
           (let lp ((i (string-cursor-start str)))
             (let ((j (string-find str #\newline i)))
-              (output indent)
+              (each indent (substring-cursor str i j))
-              (output (substring-cursor str i j))
               (if (string-cursor<? j end)
                   (lp (string-cursor-next str j))))))))))
 
 (define (c-block-comment . args)
-  (fn (col row)
+  (fn (col (row1 row))
     (let ((indent (c-indent-string col)))
       (each "/* "
             (with ((writer (make-block-comment-writer)))
               (each-in-list args))
             (fn ((row2 row))
               (cond
-               ((= row row2) (displayed " */"))
+               ((= row1 row2) (displayed " */"))
                (else (each fl indent " */"))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -402,7 +456,7 @@
                      (apply cpp-elif (cdr o))
                      (each (cpp-else) (cadr o) endif)))
                 (else endif))))
-    (fn (col)
+    (fn ()
       (each fl "#" name " " (cpp-expr check) fl
             (or pass "")
             tail fl))))

lib/chibi/show/c.sld

@@ -21,5 +21,5 @@
    cpp-error cpp-warning cpp-stringify cpp-sym-cat
    c-comment c-block-comment c-attribute)
   (import (chibi) (chibi string) (chibi show) (chibi show pretty)
-          (srfi 1) (scheme cxr))
+          (srfi 1) (srfi 165) (scheme cxr))
   (include "c.scm"))

lib/chibi/show/color.sld

@@ -1,8 +1,2 @@
 
-(define-library (chibi show color)
+(define-library (chibi show color) (alias-for (srfi 166 color)))
-  (import (scheme base) (chibi show base))
-  (export as-red as-blue as-green as-cyan as-yellow
-          as-magenta as-white as-black
-          as-bold as-underline
-          as-color as-true-color)
-  (include "color.scm"))

lib/chibi/show/column.sld

@@ -1,11 +1,2 @@
 
-(define-library (chibi show column)
+(define-library (chibi show column) (alias-for (srfi 166 columnar)))
-  (import (scheme base) (scheme char) (scheme file) (scheme write)
-          (srfi 1) (srfi 117) (srfi 130)
-          (chibi optional) (chibi show))
-  (export
-   call-with-output-generator call-with-output-generators
-   string->line-generator
-   tabular columnar show-columns wrapped wrapped/list wrapped/char
-   justified line-numbers from-file)
-  (include "column.scm"))

lib/chibi/show/pretty.sld

@@ -1,8 +1,2 @@
 
-(define-library (chibi show pretty)
+(define-library (chibi show pretty) (alias-for (srfi 166 pretty)))
-  (export pretty pretty-shared pretty-simply
-          joined/shares try-fitted
-          )
-  (import (scheme base) (scheme write) (chibi show) (chibi show base)
-          (srfi 1) (srfi 69) (chibi string))
-  (include "pretty.scm"))

lib/chibi/show/unicode.sld

@@ -1,11 +1,2 @@
 
-(define-library (chibi show unicode)
+(define-library (chibi show unicode) (alias-for (srfi 166 unicode)))
-  (import (scheme base)
-          (scheme char)
-          (chibi show base)
-          (srfi 130)
-          (srfi 151))
-  (export as-unicode
-          unicode-terminal-width unicode-terminal-width/wide
-          upcased downcased)
-  (include "width.scm" "unicode.scm"))

lib/srfi/159/base.sld

@@ -1,12 +1,29 @@
 
 (define-library (srfi 159 base)
-  (import (chibi show) (chibi show pretty))
   (export
    show fn forked with with! each each-in-list call-with-output
-   displayed written written-simply pretty pretty-simply
+   displayed written written-shared written-simply numeric nothing
-   numeric numeric/comma numeric/si numeric/fitted
+   escaped maybe-escaped numeric/si numeric/fitted numeric/comma)
-   nothing nl fl space-to tab-to escaped maybe-escaped
+  (import (scheme base) (scheme write) (scheme complex) (scheme inexact)
-   padded padded/right padded/both
+          (srfi 1) (srfi 69) (chibi string) (chibi monad environment)
-   trimmed trimmed/right trimmed/both trimmed/lazy
+          (chibi show shared))
-   fitted fitted/right fitted/both
+  (cond-expand
-   joined joined/prefix joined/suffix joined/last joined/dot joined/range))
+   (chibi
+    (import (only (chibi) let-optionals*)))
+   (else
+    (begin
+      (define-syntax let-optionals*
+        (syntax-rules ()
+          ((let-optionals* opt-ls () . body)
+           (begin . body))
+          ((let-optionals* (op . args) vars . body)
+           (let ((tmp (op . args)))
+             (let-optionals* tmp vars . body)))
+          ((let-optionals* tmp ((var default) . rest) . body)
+           (let ((var (if (pair? tmp) (car tmp) default))
+                 (tmp2 (if (pair? tmp) (cdr tmp) '())))
+             (let-optionals* tmp2 rest . body)))
+          ((let-optionals* tmp tail . body)
+           (let ((tail tmp)) . body)))))))
+  (include "../166/base.scm")
+  (include "../166/write.scm"))

lib/srfi/159/color.sld

@@ -1,6 +1,7 @@
 
 (define-library (srfi 159 color)
-  (import (chibi show color))
+  (import (scheme base) (srfi 159 base))
   (export as-red as-blue as-green as-cyan as-yellow
           as-magenta as-white as-black
-          as-bold as-underline))
+          as-bold as-underline)
+  (include "../166/color.scm"))

lib/srfi/159/columnar.sld

@@ -1,8 +1,11 @@
 
 (define-library (srfi 159 columnar)
-  (import (chibi show column))
+  (import (scheme base) (scheme char) (scheme file) (scheme write)
+          (srfi 1) (srfi 117) (srfi 130) (srfi 159 base)
+          (chibi optional))
   (export
    call-with-output-generator call-with-output-generators
    string->line-generator
    tabular columnar show-columns wrapped wrapped/list wrapped/char
-   justified line-numbers from-file))
+   justified line-numbers from-file)
+  (include "../166/column.scm"))

lib/srfi/159/unicode.sld

@@ -1,4 +1,9 @@
 
 (define-library (srfi 159 unicode)
-  (import (chibi show unicode))
+  (import (scheme base)
-  (export as-unicode unicode-terminal-width))
+          (scheme char)
+          (chibi show base)
+          (srfi 130)
+          (srfi 151))
+  (export as-unicode unicode-terminal-width)
+  (include "../166/width.scm" "../166/unicode.scm"))

lib/srfi/166/base.sld

@@ -50,5 +50,5 @@
    comma-sep comma-rule word-separator? ambiguous-is-wide?
    )
   (include "base.scm")
-  (include "../../chibi/show/write.scm")
+  (include "write.scm")
-  (include "../../chibi/show/show.scm"))
+  (include "show.scm"))

lib/srfi/166/color.sld

@@ -8,4 +8,4 @@
   (begin
     (define color
       (make-computation-environment-variable 'color #f #f)))
-  (include "../../chibi/show/color.scm"))
+  (include "color.scm"))

lib/srfi/166/columnar.sld

@@ -10,4 +10,4 @@
           (chibi optional)
           )
   (export-all)
-  (include "../../chibi/show/column.scm"))
+  (include "column.scm"))

lib/srfi/166/pretty.sld

@@ -8,5 +8,5 @@
           (srfi 1)
           (srfi 69)
           (srfi 166 base))
-  (export-all)
+  (export pretty pretty-shared pretty-simply pretty-color)
-  (include "../../chibi/show/pretty.scm"))
+  (include "pretty.scm"))

lib/srfi/166/unicode.sld

@@ -8,5 +8,5 @@
   (export as-unicode
           unicode-terminal-width unicode-terminal-width/wide
           upcased downcased)
-  (include "../../chibi/show/width.scm"
+  (include "width.scm"
-           "../../chibi/show/unicode.scm"))
+           "unicode.scm"))