#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do format-atom-feed)' -s $0 "$@" # -*-scheme-*-
!#
;;; format-atom-feed

;; Copyright (C) 2005, 2006, 2007, 2008, 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.

;;; Commentary:

;; Usage: format-atom-feed [-e ENCODING] [SEXP]
;;
;; Format SEXP into "Atom feed" XML, and write the result to stdout.
;; If SEXP is unspecified or "-", read it from stdin.
;;
;; SEXP should have (this is not validated) the format:
;;
;;   (feed
;;    (@ (xmlns "http://www.w3.org/2005/Atom"))
;;    (id ID-SPEC)
;;    (link (@ (rel "self") (href ID-SPEC)))
;;    (updated UPDATED-SPEC)
;;    (title "Example feed")
;;    (author (name "J. R. Hacker") ...)
;;    (entry (title "Atom-Powered Robots Run Amok")
;;           (link (@ (rel REL) (href URL)))
;;           (id ID-SPEC)
;;           (updated UPDATED-SPEC)
;;           (summary "Scheming bots everywhere!"))
;;    ...)
;;
;; Alternatively, each ‘entry’ can have an ‘author’, in which case
;; the top-level ‘feed’ need not include ‘author’.
;;
;; UPDATED-SPEC can be an integer, the number of seconds since epoch,
;; as returned by procedure ‘current-time’; or ‘#t’, in which case
;; the value of calling ‘current-time’ is used.  The formatted time
;; is always UTC.
;;
;; REL is typically "alternate".
;;
;; ID-SPEC is a string, the "unique id" for the #:feed or #:entry,
;; respectively.  This can be a URL.
;;
;; Option ‘--encoding’ (or ‘-e’) specifies ENCODING for the first line:
;;
;;  <?xml version="1.0" encoding="ENCODING"?>
;;
;; If unspecified, the default is "utf-8".
;;
;;
;; Notes:
;; You can check the output using: <http://feedvalidator.org>.
;; Info about Atom (spec, etc) at: <http://feedvalidator.org/docs/>.

;;; Code:

(define-module (ttn-do format-atom-feed)
  #:export (format-atom-feed
            main)
  #:use-module ((ttn-do zzz 0gx read-string) #:select (read-string))
  #:use-module ((ttn-do zzz banalities) #:select (check-hv
                                                  qop<-args))
  #:use-module ((ttn-do zzz personally) #:select (accumulator
                                                  FE))
  #:use-module ((ttn-do zzz publishing) #:select (flatten-to
                                                  expand
                                                  :LF))
  #:use-module ((ttn-do zzz xhtml-tree) #:select (~?xml)))

;; Send to @var{port} using encoding @var{enc} the @var{sexp}
;; in Atom format@footnote{@uref{http://feedvalidator.org/docs/}}.
;; If @var{port} is @code{#f}, return a string, instead.
;; Normally, the output omits inter-element whitespace.
;; Optional args @var{newline-before} is a list of elements
;; (symbols) prior to which a newline @samp{\n} should be output.
;; Valid elements (which are all of them Atom elements) are:
;;
;; @example
;; author           generator        rights
;; category         icon             source
;; content          id               subtitle
;; contributor      link             summary
;; email            logo             title
;; entry            name             updated
;; feed             published        uri
;; @end example
;;
(define (format-atom-feed port enc sexp . newline-before)
  (let ((tree: (make-object-property)))

    (define (walk x)
      (cond ((and (pair? x) (tree: (car x)))
             => (lambda (tree)
                  (apply tree (let ((acc (accumulator)))
                                (define (acc+ ls)
                                  (apply acc ls))
                                (or (null? (cdr x))
                                    (cond ((and (pair? (cadr x))
                                                (eq? '@ (caadr x)))
                                           (FE (cdadr x) acc+)
                                           (acc+ (cddr x)))
                                          (else
                                           (acc+ (cdr x)))))
                                (acc)))))
            ((pair? x)
             (map walk x))
            (else x)))

    (define (prep-body! prep)
      (lambda (elem)
        (set! (tree: elem)
              (let ((tree (expand (symbol->string elem)
                                  #:prep-body prep)))
                (if (memq elem newline-before)
                    (lambda x
                      (list :LF (apply tree x)))
                    tree)))))

    ;; prepare
    (FE `(((updated)
           . ,(lambda (x)
                (list (strftime "%FT%TZ"
                                (gmtime (if (eq? #t (car x))
                                            (current-time)
                                            (car x)))))))
          ((feed
            title author name email uri id link
            entry summary category generator icon
            logo rights subtitle content
            contributor published source)
           . ,(cons 'map walk)))
        (lambda (spec)
          (FE (car spec) (prep-body! (cdr spec)))))

    ;; do it!
    (flatten-to port (list (~?xml enc)
                           (walk sexp)
                           :LF))))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   (version . "2.0")
                   ;; 2.0  -- SXML-ish input
                   ;; 1.x  -- keyword input
                   (help . commentary)))
  (let* ((qop (qop<-args args '((encoding (single-char #\e) (value #t)))))
         (rest (qop '())))
    (format-atom-feed (current-output-port)
                      (or (qop 'encoding) "utf-8")
                      (if (or (null? rest) (string=? "-" (car rest)))
                          (read (current-input-port))
                          (read-string (car rest))))))

;;; format-atom-feed ends here