;; Various XML-related things.
;;
;; Actually, this is mostly a collection of tools for dealing with xexprs.
;;
;; This file is part of Beastie <https://purl.org/nxg/dist/beastie>
;; SPDX-FileCopyrightText: 2024 Norman Gray <https://nxg.me.uk>
;; SPDX-License-Identifier: BSD-2-Clause

(module 'unicode)

;; XEXPR-WRITE/SEXP : xexpr? -> void
;; Note: this really is pretty simple-minded, but in reality it only
;; has to be general enough to cope with the sexps we generate within
;; this program.  A full version of this functionality is a
;; nearly-700-line function in s7's write.scm.
(define/provide* (xexpr-write/sexp! el (dumb? #f))
  #"""`(xexpr-write/sexp! el :dumb?)` : write an xexpr to the stdout as a sexpr
  (ie, this is just a _very_ basic prettyprinter).

  If the keyword argument `:dumb?` is `#t`, then this uses an
  alternative writer which is less pretty but more robust."""
  (define in
    (let* ((maxin 10)
           (*indents* (make-string (+ (* 2 maxin) 1) #\space)))
      (string-set! *indents* 0 #\newline)
      (lambda (n)
        (if (> n maxin)
            *indents*
            (substring *indents* 0 (+ (* 2 n) 1))))))
  (define (w! x level prefix)
    (cond ((null? x))
          ((and (list? (car x)) (list? (caar x)))
           ;; eg (a ((name "foo")) ...) -- hacky: rather specific to xexprs!
           (printf "~a~s" prefix (car x))
           (w! (cdr x) level (in level)))
          ((list? (car x))
           (display (in level))
           (w! (car x) (+ level 1) "(")
           (display ")")
           (w! (cdr x) level (in level)))
          (else
           (printf "~a~s" prefix (car x))
           (w! (cdr x) level " "))))
  (if dumb?
      (xexpr-write/sexp!* el)
      (w! (list el) 0 "")))

;; a dumber version of the above
(define (xexpr-write/sexp!* el)
  (let-temporarily (((*s7* 'print-length) (*s7* 'most-positive-fixnum)))
    ;; (write el)
    ;; (newline)
    (display "(")
    (for-each (lambda (el) (write el) (newline))
              el)
    (display ")\n")))

(define extra-entities
  ;; Make a hash of the reasonable entities.
  ;; This particular list is lifted from
  ;; <https://developer.mozilla.org/en-US/docs/Glossary/Entity>
  ;; That refers to the frankly ridiculous list at the WhatWG site
  ;; <https://html.spec.whatwg.org/multipage/named-characters.html#named-character-references>,
  ;; which I'm not going to dignify with a second glance.
  ;;
  ;; The entities 'amp and 'lt should _not_ be in this list, since
  ;; these must not appear in output XML.  The entities &gt;, &apos;
  ;; and &quot; must be predefined by any XML parser
  ;; <https://www.w3.org/TR/xml11/#sec-predefined-ent>,
  ;; so we can choose whether or not to expand these when that's
  ;; requested.  We _choose_ here not to include &gt;, so that it
  ;; appears in X(HT)ML output as an entity, this is for symmetry with
  ;; &lt; and acting on a principle of least user surprise.
  (hash-table 'apos "'"
              'quot "\""
              'nbsp " "
              'ndash "–"
              'mdash "—"
              'copy "©"
              'reg "®"
              'trade "™"
              'asymp "≈"
              'ne "≠"
              'pound "£"
              'euro "€"
              'deg "°"))
;; Include here for reference the XML-predefined entities which are
;; _not_ included in extra-entities, above.
(define core-entities
  (hash-table 'amp "&"
              'lt "<"
              'gt ">"))

;; WRITE_XEXPR/XML! : xexpr? -> void
;; Write an xexpr to the stdout as XHTML.
;;
;; An xexpr is defined as follows (this is from
;; <https://docs.racket-lang.org/xml/index.html>).  This is distinct
;; from the original SXML
;; <https://okmij.org/ftp/Scheme/xml.html#SXML-spec>, in that it is a
;; little less general, and it encodes attributes  as
;; `((symbol? string?) ...)` rather than `(@ (symbol? string?) ...)`.
;; See <https://www.neilvandyke.org/racket/sxml-intro/> for some
;; discussion.
;;
;; In Racket, a cdata is an instance of the cdata structure type, and
;; a misc is an instance of the comment or p-i structure types.  I
;; don't implement either of these right now.
(define/provide* (xexpr-write/xml! el (expand-entities? #f) (prettyprint? #f))
  #"""(xexpr-write/xml! el :expand-entities?) : write an xexpr to the stdout as XML.

  If keyword `:prettyprint?` is present and `#t`, then prettyprint
  the XML output.  At present, this is _very_ basic, and consists
  only of adding newlines after end-tags.
  For the keyword `:expand-entities?`, see below.

  An xexpr is defined as follows; this is copying the specification
  in [Racket](https://docs.racket-lang.org/xml/index.html).

  The following grammar describes expressions that create
  X-expressions:

      xexpr = string
        | (list symbol (list (list symbol string) ...) xexpr ...)
        | (cons symbol (list xexpr ...))
        | symbol
        | valid-char?
        | cdata
        | misc

  For example:

      (xexpr-write/xml!
         '(p "Here is a " (a ((href "http://foo")) "link")
             " with " (br ((clear "right")))
             ". This" amp "that" 33))

  produces

      <p>Here is a <a href="http://foo">link</a> with <br clear="right" />. This&amp;that&#x21;</p>

  Above, a string is literal data, either as a `"string"` or `#"ustring"`.
  When converted to an XML stream, the
  characters of the data will be escaped as necessary.

  A pair represents an element, optionally with attributes. Each
  attribute’s name is represented by a symbol, and its value is
  represented by a string.

  A symbol represents an entity reference.  For example, the symbol `'nbsp`
  represents `&nbsp;`.  These are serialised as such, _unless_
  `:expand-entities?` is `#t`, in which case _a subset_ of entities are
  expanded into the nominated character.  It is unspecified just what
  entities are included in this ‘subset’, but
  [this list](https://developer.mozilla.org/en-US/docs/Glossary/Entity) is reasonable.

  A `valid-char?` represents a numeric entity. For example, `#x20` represents `&#x20;`.

  Right now, I don't implement cdata or misc."""

  ;; Re escapees, see the note about extra-entities, above
  (define (all-escapee? c)
    (cond ((char? c)
           (or (char=? c #\&)
               (char=? c #\<)
               (char=? c #\>)
               (char=? c #\')
               (char=? c #\")))
          ((and (integer? c) (< c #x7f))
           (all-escapee? (integer->char c)))
          (else #f)))
  (define (core-escapee? c)
    (cond ((char? c)
           (or (char=? c #\&)
               (char=? c #\<)
               (char=? c #\>)))
          ((and (integer? c) (< c #x7f))
           (core-escapee? (integer->char c)))
          (else #f)))

  (define (display/escaping! s escapee?)
    (cond ((string? s)
           (display-string/escaping!* s escapee?))
          ((ustring? s)
           (display-ustring/escaping!* s escapee?))
          (else                         ;odd! -- highlight this
           (print-warning "xexpr-write/xml!: unexpected item ~s" s)
           (printf "[[~s]]" s))))
  (define (display-string/escaping!* s escapee?)
    ;; this function assumes that escapee? will return true
    ;; only for one of the characters listed here
    (let ((escapee-at (string-index s escapee?)))
      (if escapee-at
          (begin
            (display (substring s 0 escapee-at))
            (case (string-ref s escapee-at)
              ((#\&) (display "&amp;"))
              ((#\<) (display "&lt;"))
              ((#\>) (display "&gt;"))
              ((#\') (display "&apos;"))
              (else  (display "&quot;")))
            (display-string/escaping!* (substring s (+ escapee-at 1)) escapee?))
          (display s))))
  (define (display-ustring/escaping!* us escapee?)
    ;; This may not be the most efficient way of approaching this.
    ;; Would it be good to have a ustring-substring/shared function
    ;; which creates a substring but shares storage?
    ;; Would that be useful, or more premature optimisation?
    (let ((escapee-at (ustring-index us escapee?)))
      (if escapee-at
          (begin
            (display (ustring-substring us 0 escapee-at))
            (case (integer->char (ustring-ref us escapee-at))
              ((#\&) (display "&amp;"))
              ((#\<) (display "&lt;"))
              ((#\>) (display "&gt;"))
              ((#\') (display "&apos;"))
              (else  (display "&quot;")))
            (display-ustring/escaping!* (ustring-substring us (+ escapee-at 1)) escapee?))
          (display us))))

  (define (write/xml*! el)
    (cond ((null? el))
          ((list? el)
           (cond ((and (symbol? (car el))
                       (not (null? (cdr el)))
                       (list? (cadr el))
                       (or (null? (cadr el))
                           (list? (caadr el))))
                  ;; an element with attributes, with or without content
                  (printf "<~a" (car el))
                  (for-each (lambda (l)
                              (printf " ~a=\"" (car l))
                              (display/escaping! (cadr l) all-escapee?)
                              (display "\""))
                            (cadr el))
                  (if (null? (cddr el))
                      (display " />")
                      (begin
                        (display ">")
                        (for-each (λ (c)
                                    (write/xml*! c))
                                  (cddr el))
                        (printf "</~a>" (car el))))
                  (when prettyprint?
                    (newline)))
                 ((symbol? (car el))
                  ;; an element with no attributes
                  (if (null? (cdr el))
                      (printf "<~a />" (car el))
                      (begin
                        (printf "<~a>" (car el))
                        (for-each (λ (c)
                                    (write/xml*! c))
                                  (cdr el))
                        (printf "</~a>" (car el))))
                  (when prettyprint?
                    (newline)))
                 (else
                  (eprintf "unexpected xexpr->xml input ignored, at start of: ~s~%" el))))
          ((symbol? el)    ; we do _not_ expand the core-entities here
           (cond ((and expand-entities? (extra-entities el)) => display)
                 (else (printf "&~a;" el))))
          ((number? el) (printf "&#x~x;" el))
          (else
           (display/escaping! el (if expand-entities? core-escapee? all-escapee?)))))

  (write/xml*! el))

(define/provide* (xexpr-write/xhtml! body (metadata #f))
  #"""(xexpr-write/xhtml! body :metadata) :
  Write an xexpr to the stdout as XHTML (ie, adding head and body elements).
  If METADATA is present, then it is taken to be a list of lists,
  `'(("key" "value") ("key" "value") ...)`
  (specifically, the result from parse-markdown/metadata),
  which is searched for an item with key `"title"`."""
  ;(eprintf "metadata -> ~s~%" metadata)
  (let ((title (cond
                ((not metadata) "Dummy title")
                ;((string? metadata) metadata)
                ((list? metadata)
                 (let loop ((ann metadata))
                   ;; search for '("title" "the title...")
                   (cond ((null? ann) "Dummy title")
                         ((string=? (caar ann) "title")
                          (cadar ann))
                         (else (loop (cdr ann))))))
                (else (beastie-error "Unexpected metadata: ~s" metadata)))))
    (display "<!DOCTYPE html\n  PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"\n  \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n")
    (xexpr-write/xml!
     `(html ((xmlns "http://www.w3.org/1999/xhtml"))
            (head
             (style "span.citation:before {content:\"(\"} span.citation:after {content:\")\"}")
             (title ,title))
            (body ,body))
     :expand-entities? #t)))

;; Here, we've chosen to write out Python strings as '...' rather then "...".
;; There's nothing deep in this choice, but I think the former looks tidier
;; than the latter, and it seems to be what Python itself choose
;; when serialising.
(define/provide (xexpr-write/python! body)
  #"""(xexpr-write/python! body) :
  Write the xexpr expression in a form which is readable by Python.
  Specifically, it's the format wrangled by https://pypi.org/project/listxml/"""
  (define (display/escaping! s)
    (define (escapee? c)
      (or (char=? c #\newline) (char=? c #\')))
    (let loop ((start 0))
      (let ((i (string-index s escapee? start)))
        (cond (i
               (printf "~a~a"
                       (substring s start i)
                       (case (string-ref s i)
                         ((#\newline) "\\n")
                         (else "\\'")))
               (loop (+ i 1)))
              ((= start 0) (display s))
              (else (display (substring s start)))))))
  (cond ((list? body)
         (receive (gi atts content)
             (xexpr-disassemble body)
           (printf "['~a'" gi)
           (unless (null? atts)
             (display ", [")
             (let loop ((l atts)
                        (sep ""))
               (unless (null? l)
                 (printf "~a['~a', '" sep (caar l))
                 (display/escaping! (cadar l))
                 (display "']")
                 (loop (cdr l) ", ")))
             (display "]"))
           (for-each (lambda (c)
                       (display ", ")
                       (xexpr-write/python! c))
                     content)
           (printf "]")))
        ((symbol? body)
         (cond ((core-entities body) => write)
               ((extra-entities body) => write)
               (else                    ;not ideal, but this is probably user-error
                (printf "'[~a]'" body))))
        (else
         (cond ((string? body)
                (display "'") (display/escaping! body) (display "'"))
               (else (write body))))))

(define xexpr-md-handlers-in-ol? #t)    ;hacky!
(define (xexpr-md-content-only att content) content)
(define xexpr-md-handlers
  (hash-table
   ;; block
   'h1	(λ (att content)
          `("\n\n" ,@content "\n====\n"))
   'h2	(λ (att content)
          `("\n\n" ,@content "\n----\n"))
   'p	(λ (att content)
          `("\n" ,@content "\n"))
   'hr	(λ (att content)
          (list "\n----\n"))
   'blockquote	(λ (att content)
                  (let ((lines (string-split (apply string-append content) #\newline)))
                    ;(eprintf "blockquote: content=~s~%lines=~s~%" content lines)
                    `("\n"
                      ,@(map (λ (l)
                               (string-append "> " l "\n"))
                             lines)
                      "\n")))
   'ol	(λ (att content)
          (set! xexpr-md-handlers-in-ol? #t)
          (cons "\n" content))
   'ul	(λ (att content)
          (set! xexpr-md-handlers-in-ol? #f)
          (cons "\n" content))
   'li	(λ (att content)
          `(,(if xexpr-md-handlers-in-ol? "  1. " "  * ") ,@content "\n"))
   'div	xexpr-md-content-only

   ;; inline
   'em	(λ (att content)
          `("_" ,@content "_"))
   'strong	(λ (att content)
                  `("**" ,@content "**"))
   'cite	(λ (att content)
                  `("(" ,@content ")"))
   'span	xexpr-md-content-only
   'a	(λ (att content)
          (cond ((assq 'href att)
                 => (λ (href)
                      `("[" ,@content "](" ,(cadr href) ")")))
                ((assq 'name att)
                 => (λ (name)
                      `("[" ,(cadr name) "] " . ,content)))
                (else content)))
   'img (λ (att content)
          `("!["
            ,(cond ((assq 'alt att) => cadr)
                   (else ""))
            "]("
            ,(cond ((assq 'src att) => cadr)
                   (else ""))
            ")"))))

(define/provide (xexpr-write/md! xexprs)
  #"""(xexpr-write/md! xexprs) :
  Convert xexprs to Markdown.
  The argument XEXPRS is a list of xexpr?.
  Writes the result to the current output port.
  This is preliminary/best-efforts, rather than being at all thorough."""
  (define (xexpr->list xe)
    ;; xexpr? -> (listof string?)
    (cond ((list? xe)
           (receive (el atts content)
               (xexpr-disassemble xe)
             (cond ((xexpr-md-handlers el)
                    => (λ (h)
                         (h atts (apply append (map xexpr->list content)))))
                   (else (eprintf "Unrecognised element: ~s~%" el)
                         (apply append (map xexpr->list content))))))
          ((string? xe) (list xe))
          ((symbol? xe)
           (list (or (core-entities xe)
                     (extra-entities xe)
                     ;not ideal, but this is probably user-error...
                     (sprintf "\"[~a]\"" xe))))
          (else
           (eprintf "Unexpected item in xexpr-write/md!: ~s~%" xe)
           (list (sprintf "~s" xe)))))
  (for-each (λ (xe)
              (for-each display (xexpr->list xe)))
            xexprs)
  (newline))

;; XEXPR-SEARCH-PATH? : any -> boolean?
;;
;; In s7, note that all keyword? objects are also symbol?
(define/provide (xexpr-search-path? x)
  #"""(xexpr-search-path? x) : The search path specification for XEXPR-PATH-SEARCH.

A sequence of symbols followed by an optional keyword.  The prefix
of symbols specifies a path of tags from the leaves with an
implicit any sequence to the root. The final, optional keyword
specifies an attribute."""
  (and (list? x)
       (not (null? x))
       (case (length x)
         ((0) #f)
         ((1) (symbol? (car x)))
         (else
          (and (symbol? (car x))
               (not (keyword? (car x)))
               (se-path? (cdr x)))))))

(define/provide (xexpr-disassemble xe)
  #"""(xexpr-disassemble xe) :
  Given an xexpr representing an element,
  return its name, attributes and contents as multiple values.
  If there are no attributes in the xexpr,
  then we return a null list for that part of the result."""
  (if (and (not (null? (cdr xe)))
           (list? (cadr xe))
           (or (null? (cadr xe))
               (list? (caadr xe))))
      (values (car xe) (cadr xe) (cddr xe))
      (values (car xe) '() (cdr xe))))

(define/provide (xexpr-get-attribute xe att)
  #"""(xexpr-get-attribute xe att) :
  Given an xexpr `xe`, return the attribute `att` (a symbol) if it's present, or #f if not."""
  (receive (gi atts content)
      (xexpr-disassemble xe)
    (cond ((assv att atts) => cadr)
          (else #f))))

(define/provide (xexpr-text xe)
  #"""(xexpr-text xe) -> string? : Given an xexpr, extract all and only the text content.
  Any entity references (ie, symbols) are deemed to be 'text' in this context,
  and expanded to the corresponding string."""
  (cond ((string? xe) xe)
        ((ustring? xe) (ustring->string xe :display))
        ((symbol? xe)
         (or (core-entities xe)
             (extra-entities xe)
             (symbol->string xe)))
        ((list? xe)
         (cond ((null? xe) "")
               ((symbol? (car xe))
                (receive (gi atts content)
                    (xexpr-disassemble xe)
                  (apply string-append (map xexpr-text content))))
               (else (apply string-append (map xexpr-text xe)))))
        (else "")))

;; Given an element with optionally present attributes, return the body
(define (element-content* xe)
  (receive (gi atts content)
      (xexpr-disassemble xe)
    content))

(define/provide (xexpr-path-search search-path xexpr)
  #"""(xexpr-path-search search-path xexpr) : search for a path in an xexpr.

  The `search-path` is a list of element names as symbols,
  predicates, or one final keyword.

  Returns a list comprised of the lists within `xexpr` which match.
  A symbol matches an element name, a predicate is true if it returns true when
  applied to an xexpr, and a trailing keyword matches an attribute name.

  Thus `'(p em)` would find all `em` elements contained within a `p` element,
  `'(p class:)` would find the `class` attribute of `p` elements
  (ie, XPath `p/@class`), and
  `(list 'p (lambda (e) (xexpr-get-attribute e 'a1)) 'q)` would match `p`
  elements which have an `a1` attribute and contain a `q` element
  (ie, XPath `p[@a1]/q`).
  """
  (define (search* p xe)
    ;;(eprintf "p=~s  xe=~s~%" p xe)
    (cond ((not (list? xe)) '())
          ((or (null? p) (null? xe)) xe)
          ((null? (cdr p))
           (cond ((eqv? (car p) (car xe))
                  ;; match
                  (list xe))
                 ((equal? p search-path)
                  ;; we were some way through search-path when the search failed
                  (apply append
                         (map (lambda (xe1) (search* search-path xe1))
                              (element-content* xe))))
                 (else
                  ;; restart with the original search-path, from here
                  (search* search-path xe))))
          ((eqv? (car p) (car xe))
           ;; match so far
           ;;(printf "so far: p=~s  xe=~s~%" p xe)
           (cond ((and (= (length p) 2)
                       (keyword? (cadr p))
                       (not (null? (cdr xe)))
                       (list? (cadr xe)))
                  (cond ((null? (cdr xe)) '())
                        ((assv (keyword->symbol (cadr p)) (cadr xe)) => list)
                        (else
                         (apply append
                                (map (lambda (xe1) (search* search-path xe1))
                                     (element-content* xe))))))
                 ((and (not (null? (cdr xe)))
                       (procedure? (cadr p)))
                  (let ((include? (cadr p)))
                    ;;(printf "p=~s  include=~s  xe=~s  inc? ~s~%" p include? xe (include? xe))
                    (if (include? xe)
                        (if (null? (cddr p))
                            (list xe)
                            (apply append
                                   (map (lambda (xe1) (search* (cddr p) xe1))
                                        (element-content* xe))))
                        (apply append
                               (map (lambda (xe1) (search* search-path xe1))
                                    (element-content* xe))))))
                 (else
                  (apply append
                         (map (lambda (xe1) (search* (cdr p) xe1))
                              (element-content* xe))))))
          (else
           (apply append
                  (map (lambda (xe1) (search* search-path xe1))
                       (element-content* xe))))))
  (search* search-path xexpr))