(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))