;;; Copyright © 2019 - 2020 Jakob L. Kreuze <zerodaysfordays@sdf.org>
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (jakob utils sxml)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:export (hyperlink
            image
            stylesheet
            script

            sanitize-subtree
            rewrite-absolute-urls-as-relative
            flatten-section-headings))


;;;
;;; Utility procedures to aid in writing SXML by hand.
;;;

(define (hyperlink target text)
  `(a (@ (href ,target)) ,text))

(define* (image file-name #:optional description)
  (let ((src (string-append "/static/image/" file-name)))
    (if description
        `(img (@ (src ,src) (alt ,description) (title ,description)))
        `(img (@ (src ,src))))))

(define (stylesheet file-name)
  `(link (@ (rel "stylesheet") (href ,(format #f "/static/css/~a" file-name)))))

(define (script file-name)
  (let ((src (string-append "/static/js/" file-name)))
    `(script (@ (src ,src)))))


;;;
;;; A reader extension for implicitly-sanitized SXML trees.
;;;

(define (sanitize-subtree subtree)
  "Remove `nil', `#f', and any unspecified elements from `sbtree'"
  (if (list? subtree)
      (map sanitize-subtree (remove (lambda (elt)
                                      (or (unspecified? elt)
                                          (eq? 'nil elt)
                                          (eq? #f elt)))
                                    subtree))
      subtree))

(define (sxml-reader chr port)
  "Read an SXML literal expression possibly containing unquote forms and
sanitize the resultant subtree."
  `(sanitize-subtree ,(cons 'quasiquote (list (read port)))))

;; Install the reader extension when imported.
(read-hash-extend #\< sxml-reader)

(define (rewrite-absolute-urls-as-relative tree)
  (match tree
    (('a attrs body ...)
     (if (assoc 'href (cdr attrs))
         (let* ((url (car (assoc-ref (cdr attrs) 'href)))
                (url (if (string-prefix? "https://jakob.space" url)
                         (string-drop url (string-length "https://jakob.space"))
                         url))
                (url (if (string-prefix? "http://jakob.space" url)
                         (string-drop url (string-length "http://jakob.space"))
                         url))
                (attrs `(@ (href ,url) ,@(filter (match-lambda
                                                   (('href _) #f)
                                                   (_         #t))
                                                 (cdr attrs)))))
           `(a ,attrs ,@body))
         tree))
    ((xs ...)
     (map rewrite-absolute-urls-as-relative xs))
    (elem elem)))

(define (flatten-section-headings tree)
  """Flattens extraneous sections output by Org-mode

This function traverses a SXML tree and removes the outermost `<div>`
elements that represent Org-mode section headings.

Args:
  tree: A SXML tree.

Returns:
  A SXML tree with the outermost Org section heading `<div>` elements
removed and their contents flattened.
  """
  (define (flatten-section-headings-inner tree)
    (define (is-org-section form)
      (match form
        ((or ('div ('@ ('id id) ('class _))
                   rest ...)
             ('div ('@ ('id id))
                   rest ...)
             ('div ('@ ('role "doc-footnote") ('class id))
                   rest ...))
         (or (string=? "footpara" id)
             (string-prefix? "text-footnotes" id)
             (string-prefix? "outline-container-org" id)
             (string-prefix? "text-org" id)))
        (_ #f)))
    (match tree
      ((? is-org-section
          ('div ('@ _ ...)
                rest ...))
       (append-map flatten-section-headings-inner rest))
      ((xs ...)
       (list (append-map flatten-section-headings-inner xs)))
      (elem (list elem))))
  (first (flatten-section-headings-inner tree)))