;;; publishing.scm

;; Copyright (C) 2001, 2002, 2004, 2005, 2006, 2007, 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 publishing)
  #:export (flatten
            flatten-to
            spew-html!
            update-page!
            update-all-html-data-pages!
            symbol<-kw/sym
            string<-kw/sym
            peel
            expand
            list<-
            css-tree
            :DQ :LF :NULL
            YYYY
            copyright
            copyright-since
            smhdwy)
  #:use-module ((ice-9 rdelim) #:select (write-line))
  #:use-module ((ice-9 rw) #:select (read-string!/partial
                                     write-string/partial))
  #:use-module ((ice-9 optargs-kw) #:select (lambda*
                                             define*
                                             let-optional*
                                             let-keywords*))
  #:use-module ((ttn-do zzz 0gx forms-from) #:select (forms<-file))
  #:use-module ((ttn-do zzz personally) #:select (accumulator
                                                  FE fs)))

;; Walk @var{tree} depth-first, displaying elements if they are strings.
;; Signal "bad type" error for non-string, non-list elements.  Optional second
;; arg @var{out} is a procedure to use instead of @code{display}.
;;
;;-args: (- 1 0)
;;
(define (flatten tree . out)
  (let ((out (if (null? out) display (car out))))
    (letrec ((walk (lambda (x)
                     (cond ((string? x) (or (string-null? x) (out x)))
                           ((null? x))
                           ((pair? x) (FE x walk))
                           (else (error "bad type:" x))))))
      (walk tree))))

;; Flatten to @var{port} (using @code{flatten}) the @var{tree}, a nested list
;; of strings.  If @var{port} is @code{#f} return a string, instead.
;;
(define (flatten-to port tree)
  (if (not port)
      (with-output-to-string (lambda () (flatten tree)))
      (flatten tree (lambda (s) (display s port)))))

;; Flatten the tree @var{html-data} into file named @var{outfile}.
;; However, if @var{outfile} exists and the result is not different,
;; then avoid modifying @var{outfile}, i.e., preserve its modification time.
;; If @var{outfile} is newly written, set its mode to @code{#o644}.
;;
;; Optional arg @var{log} is a procedure that takes a string, one
;; of "@var{outfile} unchanged" or "wrote @var{outfile}".
;;
;;-args: (- 1 0)
;;
(define (spew-html! html-data outfile . log)

  ;; Adapted from ‘(guile-baux ts-output) reality r-s!/p/n-f’
  ;; with ‘rd-offset’ hardcoded to 0.
  (define (r-s!/p/n-f buf port len)
    (define (smore-please start)
      (read-string!/partial buf port start len))
    (let loop ((this-time (smore-please 0))
               (so-far 0))
      (and (< (+ so-far this-time) len)
           (loop (smore-please so-far)
                 (+ so-far this-time)))))

  ;; Adapted from ‘(guile-baux ts-output) reality w-s/p/n-f’
  ;; with ‘end’ computed from ‘str’ instead of passed in.
  (define (w-s/p/n-f str port)
    (let ((end (string-length str))
          (b 0))
      (let loop ()
        (set! b (+ b (write-string/partial str port b end)))
        (or (= b end)
            (loop)))))

  (define (string-same-as-file s filename)
    (and (file-exists? filename)
         (let ((len (stat:size (stat filename))))
           (and (= (string-length s) len)
                (let ((on-disk (make-string len)))
                  (call-with-input-file filename
                    (lambda (port)
                      (r-s!/p/n-f on-disk port len)))
                  (string=? s on-disk))))))

  (let* ((s (flatten-to #f html-data))
         (msg (cond ((string-same-as-file s outfile)
                     "~A unchanged")
                    (else
                     (call-with-output-file outfile (lambda (port)
                                                      (w-s/p/n-f s port)))
                     (chmod outfile #o644)
                     "wrote ~A"))))
    (cond ((and (pair? log) (car log))
           => (lambda (note)
                (note (fs msg outfile)))))))

(define eval-in-current-module
  (if (and (defined? 'current-module)
           (not (defined? 'eval2)))
      (lambda (x)
        (eval x (current-module)))
      (lambda (x)
        (eval2 x (standard-eval-closure (interaction-environment))))))

;; ``Load'' @var{template-file} (evaluating it in the ``current module''),
;; and pass it as the @var{html-data} arg, along with @var{outfile} and
;; @var{log}, to @code{spew-html!}.
;;
;;-args: (- 1 0)
;;
(define (update-page! template-file outfile . log)
  (apply spew-html!
         (eval-in-current-module (car (forms<-file template-file)))
         outfile log))

;; For each filename in the list @var{pages}, do @code{update-page!}
;; on it with the template file named @var{filename}-data.  For example,
;; specifying @code{("index.html" "foo-bar-baz")} processes
;; @file{index.html-data} to create @file{index.html}, and
;; @file{foo-bar-baz-data} to create @file{foo-bar-baz}.
;;
(define (update-all-html-data-pages! pages)
  (FE pages (lambda (page)
              (update-page! (fs "~A-data" page) page write-line))))

(define :DQ "\"")
(define :LF "\n")
(define :SPC " ")
(define :EQU "=")
(define :NULL "")
(define :SEMI ";")
(define :COLON ":")
(define :COMMA ",")

;; Return @var{keyword-or-symbol} as a symbol.
;;
(define (symbol<-kw/sym keyword-or-symbol)
  (if (keyword? keyword-or-symbol)
      (keyword->symbol keyword-or-symbol)
      keyword-or-symbol))

;; Return @var{keyword-or-symbol} as a string.
;;
(define (string<-kw/sym keyword-or-symbol)
  (symbol->string (symbol<-kw/sym keyword-or-symbol)))

;; Scan @var{list} of the form:
;;
;; @example
;; ([@var{attr-name} @var{attr-value} ...] [@var{body}...])
;; @end example
;;
;; Each @var{attr-name} is either a keyword or a symbol.  Each
;; @var{attr-value} is either a string, a (possibly) nested list of
;; strings, a symbol or a number.  When there are no more attribute
;; names, the rest of the list (which may be null) is taken as the
;; @var{body}.
;;
;; Return a pair whose car is the @dfn{attributes}, formatted (in a
;; tree) as @code{NAME="VALUE"}; and whose cdr is the @var{body}.
;;
(define (peel list)
  (let ((attrs (accumulator)))
    (let loop ((ls list))
      (cond ((and (pair? ls) (or (keyword? (car ls))
                                 (symbol? (car ls))))
             (and (cadr ls)
                  (let ((attr (car ls))
                        (value (cadr ls)))
                    (attrs :SPC
                           (string<-kw/sym attr)
                           :EQU
                           :DQ
                           (if (or (string? value)
                                   (list? value))
                               value
                               (object->string value))
                           :DQ)))
             (loop (cddr ls)))
            (else
             (cons (attrs) ls))))))

;; Return a proc @var{p} that expands into a tree based on @var{elem}.
;; Precisely, @var{p} partitions its arglist with @code{peel} into
;; @var{attributes} and @var{body} and returns the tree:
;;
;; @example
;; ("<" @var{elem} @var{attributes} [" /"] ">"
;;  [@var{neck}]
;;  [@var{body} ["</" @var{elem} ">"]]
;;  [@var{tail}])
;; @end example
;;
;; Other args are keywords.  Here is a list (with default value):
;;
;; @table @code
;; @item #:xbsc #f
;; Non-@code{#f} means ``XMLish (blech) start close'', i.e., the start
;; tag should be rendered as @samp{<ELEM />} instead of of @samp{<ELEM>}
;; (with space and slash before closing angle bracket).  Typically, this is
;; specified in conjunction with @code{#:end-tag :NULL}.
;;
;; @item #:neck :NULL
;; This is inserted between the initial tag and is not subjected
;; to @code{prep-body}.  Typically @code{:LF} when specified.
;;
;; @item #:prep-body #f
;; This can be a procedure that is passed @var{body} and returns
;; a transformed tree.  It can also be a a pair whose @sc{car} is the
;; symbol @code{map} and whose @sc{cdr} is a procedure taking one arg.
;; The effective body is computed by mapping this procedure over all
;; the top-level elements of @var{body}.
;;
;; @item #:no-end-tag-if-null-body? #f
;; Non-@code{#f} specifies that if @var{body} is the empty list,
;; the @samp{</ELEM>} end tag should be omitted entirely.
;;
;; @item #:end-tag #f
;; Specifies an alternative end tag.
;;
;; @item #:tail :NULL
;; A value to be appended at the very end of the tree.
;; Typically @code{:LF} when specified.
;; @end table
;;
(define* (expand elem
                 #:key
                 (xbsc #f)
                 (neck :NULL)
                 (prep-body #f)
                 (no-end-tag-if-null-body? #f)
                 (end-tag #f)
                 (tail :NULL))
  (let ((:L (string-append "<" elem))
        (:R (if (not xbsc) ">" " />"))
        (:E (string-append "</" elem ">"))
        (body<- (cond ((not prep-body) identity)
                      ((procedure? prep-body) prep-body)
                      ((and (pair? prep-body)
                            (eq? 'map (car prep-body))
                            (cdr prep-body))
                       => (lambda (prep)
                            (lambda (x)
                              (map prep x)))))))
    (lambda x
      (let* ((acc (accumulator))
             (split (peel x))
             (attributes (car split))
             (body (body<- (cdr split)))
             (null-body? (null? body)))
        (acc :L)
        (or (null? attributes) (apply acc attributes))
        (acc :R)
        (or (eq? :NULL neck) (acc neck))
        (or null-body? (apply acc body))
        (or (and null-body? no-end-tag-if-null-body?)
            (eq? :NULL end-tag)
            (acc (or end-tag :E)))
        (or (eq? :NULL tail) (acc tail))
        (acc)))))

;; If @var{arg} is already a list, return it.
;; Otherwise return @code{(list @var{arg})}.
;;
(define (list<- arg)
  (if (list? arg)
      arg
      (list arg)))

;; Return a tree made from expanding CSS @var{rule}, a list of the form:
;; @lisp
;; (@var{target} [@var{property} @var{value}...])
;; @end lisp
;;
;; In this form, @var{target} can be a string or a flat list of strings;
;; @var{property} can be a string, symbol, or keyword, and @var{value}
;; can be a string or a nested list of strings.
;;
(define (css-tree rule)
  (let ((acc (accumulator))
        (target (car rule)))
    (if (string? target)
        (acc target)
        (begin
          (acc (car target))
          (let loop ((ls (cdr target)))
            (or (null? ls)
                (begin
                  (acc :COMMA (car ls))
                  (loop (cdr ls)))))))
    (acc "{")
    (let loop ((ls (cdr rule)))
      (or (null? ls)
          (begin
            (acc (string<-kw/sym (car ls))
                 :COLON
                 (cadr ls)
                 :SEMI)
            (loop (cddr ls)))))
    (acc "}" :LF)
    (acc)))

;; Return current year, as a string.
;;
(define (YYYY)
  (strftime "%Y" (localtime (current-time))))

;; Return tree with optional @var{prefix}:
;; @lisp
;; ("Copyright (C) " prefix YEAR " Thien-Thi Nguyen")
;; @end lisp
;;
(define (copyright . prefix)
  (list "Copyright (C) " prefix (YYYY) " Thien-Thi Nguyen"))

;; Call @code{copyright}, specifying as prefix the range of years
;; beginning with @var{year}, if that is not the current year.
;; If it is the current year, specify no prefix.
;;
(define (copyright-since year)
  (copyright
   (let ((year (cond ((string? year) year)
                     ((number? year) (number->string year))
                     (else (error "bad type")))))
     (if (string=? year (YYYY))
         (list)
         (list year "-")))))

;; Return a tree describing the time duration @var{diff} (number of
;; seconds).  Blocks are (suffix, name, max value, number of seconds):
;;
;; @multitable @columnfractions .1 .2 .1 .6
;; @item @t{s}
;; @tab seconds
;; @tab @t{59}
;; @tab @t{1}, @code{(*)}
;;
;; @item @t{m}
;; @tab minutes
;; @tab @t{59}
;; @tab @t{60}, @code{(* 60)}
;;
;; @item @t{h}
;; @tab hours
;; @tab @t{23}
;; @tab @t{3600}, @code{(* 60 60)}
;;
;; @item @t{d}
;; @tab days
;; @tab @t{90}
;; @tab @t{86400}, @code{(* 60 60 24)}
;;
;; @item @t{w}
;; @tab weeks
;; @tab @t{104}
;; @tab @t{604800}, @code{(* 60 60 24 7)}
;;
;; @item @t{y}
;; @tab years
;; @tab (none)
;; @tab @t{31536000}, @code{(* 60 60 24 365)}
;; @end multitable
;;
;; Note that the number of seconds for years is approximate.
;; If @var{diff} is negative, the tree begins with "-".
;; Optional arg @var{sep} (a string) means to recurse on the
;; remainder of the time, inserting @var{sep} between each block.
;; Some examples:
;;
;; @lisp
;; (flatten (smhdwy 12313)) @result{} "3h"
;; (flatten (smhdwy -341231343)) @result{} "-10y"
;; (flatten (smhdwy -3412314 ",")) @result{} "-39d,11h,51m,54s"
;; @end lisp
;;
;;-args: (- 1 0)
;;
(define (smhdwy diff . sep)
  (let* ((n (abs diff))
         (f (lambda (suffix den)
              (let ((one (list (number->string (quotient n den)) suffix)))
                (if (null? sep)
                    one
                    (let ((still (remainder n den)))
                      (if (zero? still)
                          one
                          (list one (car sep) (smhdwy still sep)))))))))
    (list (if (> 0 diff) "-" :NULL)
          (cond ((< n (* 60))             (f "s" (*)))
                ((< n (* 60 60))          (f "m" (* 60)))
                ((< n (* 60 60 24))       (f "h" (* 60 60)))
                ((< n (* 60 60 24 90))    (f "d" (* 60 60 24)))
                ((< n (* 60 60 24 365 2)) (f "w" (* 60 60 24 7)))
                (else                     (f "y" (* 60 60 24 365)))))))

;;; publishing.scm ends here