;;; personally.scm

;; Copyright (C) 2009, 2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Code:

(define-module (ttn-do zzz personally)
  #:export-syntax (FE HFE condition-case whatever)
  #:export (fs fso fse make-fso
               accumulator
               forms<-port))

;; Basically: @code{(for-each @var{proc} @var{ls1} @dots{} @var{lsN})}@*
;; @var{proc} is an @var{n}-ary procedure, where @var{n} is the
;; number of lists.
;;
;;-sig: (ls1 [... lsN] proc)
;;
(define-macro (FE . args)
  (let ((proc (car (last-pair args))))
    `(for-each ,proc ,@(delq proc args))))

;; Expand to @code{hash-for-each} like so:
;; @example
;; (HFE (k v ht) foo...)
;; @result{}
;; (hash-for-each (lambda (k v) foo...) ht)
;; @end example
;;
;;-sig: ((k v ht) body[...])
;;
(define-macro (HFE head . body)
  `(hash-for-each (lambda (,(car head) ,(cadr head))
                    ,@body)
                  ,(caddr head)))

;; Execute @var{bodyform} and return its value if no error happens.
;; Each element of @var{handlers} looks like
;; @code{(@var{condition-name} @var{body})}
;; where the @var{body} is one or more Scheme expressions.
;;
;; A handler is applicable to an error
;; if @var{condition-name} is one of the error's condition names.
;; If an error happens, run the first applicable handler.
;;
;; The @sc{car} of a handler may be a list of condition names instead of
;; a single condition name.  Then it handles all of them.  As a special
;; case, for the last handler specified in @var{handlers}, the @sc{car}
;; may also be the symbol @code{else}, which matches any condition name.
;;
;; Note that unlike the Emacs Lisp @code{condition-case} (from which the
;; Scheme design and documentation draw grateful inspiration), @var{var}
;; @strong{must} be specified (it cannot be @code{#f}).
;;
;; When a handler handles an error, control returns to the
;; @code{condition-case} and it executes the handler's @var{body}
;; with @var{var} bound to
;; @code{(@var{signaled-condition} . @var{signal-data})}
;; from the error, returning the value of the last @var{body} form.
;;
(define-macro (condition-case var bodyform . handlers)
  `(catch
    #t (lambda ()
         ,bodyform)
    (lambda ,var
      (case (car ,var)
        ,@(map (lambda (h)
                 ;; Emacs Lisp ‘case’ handles lone symbols,
                 ;; which is pleasant.
                 `(,(let ((name (car h)))
                      (if (or (eq? 'else name) (pair? name))
                          name
                          (list name)))
                   ,@(cdr h)))
               handlers)
        ,@(if (assq 'else handlers)
              '()
              `((else (apply throw ,var))))))))

;; Apply @code{simple-format} to format string @var{s} and @var{args}.
;; Return a string.
;;
(define (fs s . args)
  (apply simple-format #f s args))

;; Apply @code{simple-format} to format string @var{s} and @var{args}.
;; Send the result to the current output port.
;;
(define (fso s . args)
  (apply simple-format #t s args))

;; Apply @code{simple-format} to format string @var{s} and @var{args}.
;; Send the result to the current error port.
;;
(define (fse s . args)
  (apply simple-format (current-error-port) s args))

;; Return a procedure that acts like @code{fso} for @var{port}.
;;
(define (make-fso port)
  (lambda (s . args)
    (apply simple-format port s args)))

;; Return an accumulator.
;;
(define (accumulator)
  (let* ((ls (list #f))
         (tp ls))
    (lambda stuff
      (cond ((null? stuff) (cdr ls))
            (else (set-cdr! tp stuff)
                  (set! tp (last-pair tp)))))))

;; Return a list of forms @code{read} from @var{port}.
;;
(define (forms<-port port)
  (let ((acc (accumulator)))
    (let loop () (let ((form (read port)))
                   (cond ((eof-object? form) (acc))
                         (else    (acc form) (loop)))))))

;; Evaluate @var{body}.  The value is explicitly ``unspecified''.
;;
(define-macro (whatever . body)
  `(begin
     ,@body
     (if #f #f)))

;;; personally.scm ends here