From 9af3b2b445dfb7d03376bd01d52491175c20515e Mon Sep 17 00:00:00 2001
From: Case Duckworth
Date: Tue, 29 Aug 2023 21:54:21 -0500
Subject: Move chicanery.extras.scm -> extras.scm

---
 chicanery.extras.scm | 150 ---------------------------------------------------
 extras.scm           |  50 +++++++++++++++++
 2 files changed, 50 insertions(+), 150 deletions(-)
 delete mode 100644 chicanery.extras.scm
 create mode 100644 extras.scm

diff --git a/chicanery.extras.scm b/chicanery.extras.scm
deleted file mode 100644
index ae2823e..0000000
--- a/chicanery.extras.scm
+++ /dev/null
@@ -1,150 +0,0 @@
-(export list-map list-for-each list-append
-        map for-each append)
-
-(define list-map map)
-(define list-for-each for-each)
-(define list-append append)
-
-(define (map proc . collections)
-  (let ((first (car collections)))    ; we only need to check the first one
-    (cond
-     ((list? first)
-      (apply list-map proc collections))
-     ((vector? first)
-      (apply vector-map proc collections))
-     ((string? first)
-      (apply string-map proc collections))
-     (else (error "Bad datatype" first)))))
-
-(define (for-each proc . collections)
-  (let ((first (car collections)))    ; we only need to check the first one
-    (cond
-     ((list? first)
-      (apply list-for-each proc collections))
-     ((vector? first)
-      (apply vector-for-each proc collections))
-     ((string? first)
-      (apply string-for-each proc collections))
-     (else (error "Bad datatype" first)))))
-
-(define (append . collections)
-  (let ((first (car collections)))    ; we only need to check the first one
-    (cond
-     ((list? first)
-      (apply list-append collections))
-     ((vector? first)
-      (apply vector-append collections))
-     ((string? first)
-      (apply string-append collections))
-     ((bytevector? first)
-      (apply bytevector-append collections))
-     (else (error "Bad datatype" first)))))
-
-;;; Extended generic functions.
-;; These functions already have a list- version defined, but no non-prefixed
-;; one.  So I'm fixing that.
-(define (ref collection k)
-  (cond
-   ((list? collection)
-    (list-ref collection k))
-   ((vector? collection)
-    (vector-ref collection k))
-   ((string? collection)
-    (string-ref collection k))
-   ((bytevector? collection)
-    (bytevector-u8-ref collection k))
-   (else (error "Bad datatype" collection))))
-
-;; I'm not going to generalize -copy! because I don't think it's a great idea,
-;; really.
-(define (copy collection)
-  (cond
-   ((list? collection)
-    (list-copy collection))
-   ((vector? collection)
-    (vector-copy collection))
-   ((string? collection)
-    (string-copy collection))
-   ((bytevector? collection)
-    (bytevector-copy collection))
-   (else (error "Bad datatype" collection))))
-
-;;; Definitions that should be in scheme
-;; This sections should be as small as possible
-
-(export read-port
-        read-port-chunk-size)
-
-
-(define (%read-port port)
-  (let ((chunk-size (read-port-chunk-size)))
-    (let loop ((next (read-string chunk-size port))
-               (blank? #f)
-               (acc '()))
-      (cond
-       ((or (eof-object? next)
-            (and blank? (equal? next "")))
-        (apply string-append (reverse acc)))
-       ((equal? next "")
-        (loop (read-string chunk-size port)
-              #t
-              (cons next acc)))
-       (else
-        (loop (read-string chunk-size port)
-              blank?
-              (cons next acc)))))))
-
-(define read-port-chunk-size
-  (make-parameter 512))
-
-(define read-port
-  (case-lambda
-    (() (%read-port (current-input-port)))
-    ((p) (%read-port p))))
-
-(export atom? defined?)
-
-(define (atom? x)
-  (not (or (null? x)
-           (pair? x))))
-
-(define (defined? sym)
-  (call-with-current-continuation
-   (lambda (k)
-     (with-exception-handler
-         (lambda (e) (k #f))
-       (lambda ()
-         (eval sym (interaction-environment))
-         #t)))))
-
-(export with-output-to-string
-        with-input-from-string)
-
-(define (with-output-to-string thunk)
-  (call-with-port (open-output-string)
-    (lambda (port)
-      (parameterize ((current-output-port port))
-        (thunk))
-      (get-output-string port))))
-
-(define (with-input-from-string s thunk)
-  (call-with-port (open-input-string s)
-    (lambda (port)
-      (parameterize ((current-input-port port))
-        (thunk)))))
-
-(export displayed ->string written print)
-
-(define (displayed x)
-  (with-output-to-string
-    (lambda () (display x))))
-
-(define (written x)
-  (with-output-to-string
-    (lambda () (write x))))
-
-(define (print . xs)
-  (for-each display xs)
-  (newline))
-
-(define ->string displayed)
diff --git a/extras.scm b/extras.scm
new file mode 100644
index 0000000..423c78f
--- /dev/null
+++ b/extras.scm
@@ -0,0 +1,50 @@
+;;; Chicanery extras
+
+(export slurp)
+
+(define slurp
+  (case-lambda
+    (() (slurp (current-input-port)))
+    ((port)
+     (let loop ((ch (read-char port))
+                (acc '()))
+       (if (eof-object? ch)
+           (list->string (reverse acc))
+           (loop (read-char port)
+                 (cons ch acc)))))))
+
+
+(export with-output-to-string
+        with-input-from-string)
+
+(define (with-output-to-string thunk)
+  (call-with-port (open-output-string)
+    (lambda (port)
+      (parameterize ((current-output-port port))
+        (thunk))
+      (get-output-string port))))
+
+(define (with-input-from-string s thunk)
+  (call-with-port (open-input-string s)
+    (lambda (port)
+      (parameterize ((current-input-port port))
+        (thunk)))))
+
+
+(export displayed ->string
+        written
+        print)
+
+(define (displayed x)
+  (with-output-to-string
+    (lambda () (display x))))
+
+(define ->string displayed)
+
+(define (written x)
+  (with-output-to-string
+    (lambda () (write x))))
+
+(define (print . xs)
+  (for-each display xs)
+  (newline))
-- 
cgit 1.4.1-21-gabe81