1 files changed, 145 insertions, 0 deletions

@@ -0,0 +1,145 @@
+(module (chicanery extras) ( append for-each map
+                             list-append list-for-each list-map
+                             ref copy
+                             atom? defined?
+                             read-port-chunk-size read-port
+                             with-output-to-string with-input-from-string
+                             displayed written print ->string)
+  (import scheme (chicanery base))
+
+  (define list-append append)
+  (define list-for-each for-each)
+  (define list-map map)
+
+  (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
+
+  (define (atom? x)
+    (and (not (pair? x))
+         (not (null? x))))
+
+  (define read-port-chunk-size
+    (make-parameter 512))
+
+  (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
+    (case-lambda
+      (() (%read-port (current-input-port)))
+      ((p) (%read-port p))))
+
+  (define (defined? sym)
+    (call-with-current-continuation
+     (lambda (k)
+       (with-exception-handler
+           (lambda (e) (k #f))
+         (lambda ()
+           (eval sym (interaction-environment))
+           #t)))))
+
+  (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)))))
+
+  (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))