;; Parsing Markdown
;;
;; Some of the functions here, notably mdinline:XXX, are helper
;; functions, intended to be called from the Bison parse, to do
;; rearranging that is most easily done in Scheme, rather than C.
;; They should never be called by anything other than the function
;; they're helping.
;;
;; 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

(define *requires-implementation-functions*
  '(parse-markdown-source/metadata** parse-mdinline**))

(module 'xexpr 'unicode)
(define-macro (%module-verbosity-flag%) 32)

;; MDINLINE:STRINGS-TO-PARA : (listof string?) boolean? integer? -> (listof (p string?))
;; See parse-markdown.y.  The first argument is a list of strings
;; representing equally-indented lines in a single paragraph.  Argument REVERSED?
;; indicates whether the lines are arriving in reverse order or not.
;; We concatenate the strings into a single one, and run it through
;; parse-mdlnline.
;;
;; The result is a `(p "string")` element.
;;
;; Argument LINENO is the line number which should be reported in
;; error messages; it's probably the line _after_ the paragraph we're processing.
(define (mdinline:strings-to-para strings/list reversed? metadata source lineno)
  #;(let ((s (parse-mdinline**
            (string-trim (string-join (if reversed? (reverse strings/list) strings/list) " "))
            metadata
            source
            lineno)))
    (eprintf "strings-to-para (~a:~a): ~s...~%" source lineno
             (if (string? (car s))
                 (substring (car s) 0 20)
                 (car s)))
    (cons 'p s))
  (cons 'p
        (parse-mdinline**
         (string-trim (string-join (if reversed? (reverse strings/list) strings/list) " "))
         metadata
         source
         lineno)))

;; MDINLINE:PARSE-AND-WRAP : string? symbol? integer? -> (symbol? string?)
;; Given a string representing inline markdown,
;; produce an element wrapping the parsed content.
(define (mdinline:parse-and-wrap str gi metadata source lineno)
  (if (memq gi '(h1 h2 h3 h4 h5 h6))
      (let ((anchor                     ;wrap in <a name='anchor'>...</a>
             (ustring->string
              (make-ustring
               (filter values
                       (map (λ (c)
                              (cond ((char-upper? c) (uchar-downcase c))
                                    ((or (char-lower? c) (char-digit? c)) c)
                                    ((char=? c #\space) #\-)
                                    (else #f)))
                            (string->list str))))
              :display)))
        `(,gi (a ((name ,anchor)) . ,(parse-mdinline** str metadata source lineno))))
      (cons gi (parse-mdinline** str metadata source lineno))))

;; Register one or more citations, from parse-mdinline.y.
;; CITATIONS is a list of 3-element lists, each of which is
;; (pre-text citation/string post-text)
;; (eg, '(#f "smith99" ", p.99")).
;; We create a (cite <citation>) element, call ADD-METADATA to lodge a
;; reference to this element keyed with the citation/symbol, and expand
;; to a (span ...) element comprising the reference.
(define (mdinline:assemble-citations citations add-metadata)
  ;(eprintf "assemble-citation: ~s~%" citations)
  (let ((citations/list (map (λ (c)
                               (let ((cite `(cite ,(cadr c))))
                                 (add-metadata
                                  (list 'citation (string->symbol (cadr c)) cite))
                                 (filter values
                                         (list (car c)
                                               cite
                                               (caddr c)))))
                             citations)))
    `(span ((class "citation"))
           "("
           ,@(apply append
                    (let loop ((c citations/list)
                               (res '()))
                      (cond ((null? c) res)
                            ((null? res) (loop (cdr c) (list (car c))))
                            (else (loop (cdr c) `(,(car c) ("; ") . ,res))))))
           ")")))

;; MARKDOWN:ASSEMBLE-LIST-ITEMS : (listof (list type alist (list content ...))) (any -> any) string?
;;    -> (ol ...) or (ul ...)
;;
;; The argument is a list of items
;; (symbol alist list-of-strings), representing the list
;; items read from the input, in reverse order of being encountered.
;;
;; Here the symbol is 'ul or 'ol if the item
;; started out with '*' or '1.', or 'p if the item is a continuation paragraph
;; (that is, a second paragraph within a list item).
;; The alist is '(symbol . value), where the symbol is
;;    'blank?, true if the list item was preceded by a blank line (and thus
;;       whether the contents should be wrapped in <p>...</p>.
;;    'sublist?, true if this was more indented
;     'line-number, The integer is the line number of the source.
;; The list-of-strings is the item contents, as a list of strings.
;;
;; The basic structure of the following is that we work through the
;; list items backwards -- ie, we encounter the last items first --
;; and add them to the result if they are list items, to a collection
;; of subitems if (annot li 'subitem?) is true, and to a collection of
;; subparagraphs if they are (p...) rather than (ol/ul ...).  Much of
;; the complication comes when we have to decide whether the li
;; contents are compact or not, meaning that they should be
;; (li (p...)) or plain (li ...).
;;
;; Take the structure of the overall list from the first item we encounter
;; (which is the last item in the list we receive), so that a list which
;; contains both '*' and '1.' items, will be formatted according to
;; the first one.  The list items will be compact (ie, not enclosed in (p ...))
;; by default if the first encountered item has no subparagraphs and
;; isn't preceded by a blank.  In both cases, we
;; are in effect assuming that the list is homogeneous, so it doesn't
;; matter which list item we take to be representative.
;;
;; The corresponding structure of the sublists is managed
;; item-by-item.  This might produce slightly inconsistent results if
;; they appear with a mixture of spaces before, and not, but that may
;; or may not be what the author intended.  That also means that the
;; lists and sublists are not handled fully symmetrically -- is that a
;; significant wart?
(define (markdown:assemble-list-items list-of-li metadata input-source)
  (define (annot li key)
    (cond ((assq key (cadr li)) => cdr)
          (else #f)))
  ;(eprintf "markdown:assemble-list-items ~s~%" list-of-li)
  (let ((is-ol? (eqv? (caar list-of-li) 'ol))
        (default-compact?
          ;; false, if the first item (ie, last markdown item) is not a 'p (ie, it's 'ol or 'ul),
          ;; OR the list-of-li is longer than 1 item,
          ;;    and the first element's annotations includes (blank? . #t)
          ;; (that is, a single-item list is processed the same way
          ;; whether or not it is preceded by a blank line)
          (not (or (eqv? (caar list-of-li) 'p)
                   (and (> (length list-of-li) 1)
                        (annot (car list-of-li) 'blank?))))))
    ;(eprintf "  [is-ol? ~s, default-compact? ~s]~%" is-ol? default-compact?)
    (let loop ((l list-of-li)
               (sublist '())
               (sublist-is-ol? #f)
               (paras '())
               (res '()))
      ;(eprintf "    l=~s  sublist=~s  paras=~s  res=~s~%" l sublist paras res)
      (cond ((null? l)
             (cons (if is-ol? 'ol 'ul) res))
            ((eqv? (caar l) 'p)
             (loop (cdr l)
                   sublist
                   sublist-is-ol?
                   (cons (car l) paras)
                   res))
            (else
             (let* ((compact-li? (and (null? paras)
                                      (if (annot (car l) 'subitem?)
                                          (not (annot (car l) 'blank?))
                                          default-compact?)))
                    (li+paras (map (λ (li)
                                     (mdinline:strings-to-para
                                      (list-ref li 2)
                                      #f
                                      metadata
                                      input-source
                                      (or (annot li 'line-number) 0)))
                                   (cons (car l) paras)))
                    (the-li (if compact-li?
                                (cons 'li (cdar li+paras))
                                (cons 'li li+paras))))
               ;(eprintf "(car l)=~s  the-li=~s  compact-li?=~s~%" (car l) the-li compact-li?)
               (cond ((annot (car l) 'subitem?)
                      (loop (cdr l)
                            (cons the-li sublist)
                            (eqv? (caar l) 'ol)
                            '()
                            res))
                     ((null? sublist)
                      (loop (cdr l)
                            '()
                            #f
                            '()
                            (cons the-li res)))
                     (else
                      (loop (cdr l)
                            '()
                            #f
                            '()
                            `(,(append the-li `((,(if sublist-is-ol? 'ol 'ul) . ,sublist))) . ,res))))))))))

;; flatten a list into a string, for lookup purposes
(define (string-list->string sl)
  (cond ((string? sl) sl)
        ((list? sl) (apply string-append (map string-list->string sl)))
        ((not sl) "")
        (else (sprintf "~a" sl))))

;; lowercase string? -> string? via ustring
(define (lowercase/unicode s)
  (ustring->string
   (ustring-lowercase
    (make-ustring s))
   :display))

(define (markdown:assemble-result parse-tree metadata-accumulator)
  ;; The interface here is rather weird, but intended to be as
  ;; convenient as possible to the Bison parser that calls it: that
  ;; parser just chomps the input, this function does the clever stuff.
  ;;
  ;; The `parse-tree` includes HTML/sexp which includes `a` elements
  ;; with `((href "dummylink"))` (literally that dummy link).
  ;;
  ;; (metadata-accumulator #f) returns a list of entries which include...
  ;;
  ;;    (ref-def*      "linkref" "uri" "title"-or-false)
  ;;    (ref-in-tree*  "linkref" ((href "dummylink")) ("link contents"))
  ;;
  ;; where the ref "linkname" may be empty, indicating that we should
  ;; use the "title", and the ((href "dummylink")) is a reference to
  ;; one of the attribute lists in the parse tree.  Rewrite the latter
  ;; using the link-definitions in the former.
  ;;
  ;; We coerce both linkrefs to lowercase for comparison.
  ;;
  ;; Specifically,
  ;;
  ;;    * `[Google]: http://google.com` turns into `(ref-def* "google" "http://google.com" #f)`
  ;;    * `[text _with_ formatting][ref1]` in the text turns into
  ;;      `(ref-in-tree* "ref1" ((href "dummylink")) ("text " (em "with") " formatting"))`
  ;;    * `[Google][]` turns into `(ref-in-tree* "" ((href "dummylink")) ("Google"))`
  ;;
  ;; Rewrite the parse tree in this context, so that we replace the "dummylink",
  ;; in place, with the correct URI.  We don't currently do anything with the link 'title'.
  ;;
  ;; This function is called from core.c, to assemble the results from the markdown parse.
  #;(eprintf "markdown:assemble-result :~%  parse-tree=~s~%" parse-tree)
  (let ((metadata (metadata-accumulator #f)))
    ;;(eprintf "  metadata=~s~%" metadata)
    (if (null? metadata)
        (values parse-tree '())
        (let ((ref-defs (apply hash-table
                               (apply append
                                      (map (λ (p)
                                             ;; produce ("linkref" ("uri" "title"))
                                             `(,(lowercase/unicode (cadr p)) ,(cddr p)))
                                           (filter (λ (l)
                                                     (eqv? (car l) 'ref-def*))
                                                   metadata)))))
              (refs-in-tree (map (λ (l)
                                   (cons (lowercase/unicode (cadr l))
                                         (cddr l)))
                                 (filter (λ (l)
                                           (eqv? (car l) 'ref-in-tree*))
                                         metadata))))
          #;(eprintf "markdown:assemble-result: metadata~{~%  ~s~}~%ref-defs~{~%  ~s~}~%refs-in-tree~{~%  ~s~}~%"
                   metadata ref-defs refs-in-tree)

          (define (fix-uri+title atts uri+title)
                                        ;(eprintf "-> ~s~%" uri+title)
            (set-car! (cdar atts) (car uri+title))
            (when (cadr uri+title)
              (set-cdr! atts `((title ,(cadr uri+title))))))
          (for-each (λ (l)
                      (let ((ref (car l))
                            (atts (cadr l))
                            (content (caddr l)))
                        (cond ((ref-defs ref)
                               => (λ (uri+title)
                                    (fix-uri+title atts uri+title)))
                              ((ref-defs
                                (lowercase/unicode (string-list->string content)))
                               => (λ (uri+title)
                                    (fix-uri+title atts uri+title))))))
                    refs-in-tree)
          (values parse-tree metadata)))))

;; supporting parse-markdown.y: various last-minute adjustments to an apparent para element
;; (only one just now)
(define (markdown:preen-para p)
  (cond ((and (>= (length p) 2)
              (list? (cadr p))
              (eqv? (caadr p) 'img))
         ;; (p (img ((src "url") (alt "text"))) ...)
         ;; We include any other (p) content.  We presume this is a
         ;; list of other images, but it could be text, too.
         ;; The figcaption is obtained only from the first element, though.
         `(figure
           ,@(cdr p)
           (figcaption           ; use first title then alt as caption
            ,(cond ((assv 'title (cadadr p)) => cadr)
                   ((assv 'alt (cadadr p)) => cadr)
                   (else "[no caption]")))))
        (else p)))

;; The 'accumulator' function passed to some parsers is (X -> unspecified)
;; or (#f -> (collection-of X)).
;; When it's called with an argument, it saves that in its collection,
;; and when it's called with argument #f, it returns that collection.
;; The MAKE-ACCUMULATOR* function returns a simple case, but this
;; could potentially create a hash, or filter its input.
(define (make-accumulator*)
  (let ((*l* '()))
    (lambda (item)
      (if item
          (set! *l* (cons item *l*))
          *l*))))

(define/provide (parse-markdown-file fn)
  #"""`parse-markdown-file : string? -> list?` : Given a file name, parse it as Markdown
  and return the parse-tree.

  The parse tree is an x-expression, containing a list of paragraph-level
  elements inside an enclosing `(div ...)`; see the `'xexpr` module.

  For example, the Markdown

      This is a [link](http://example.org).
      ...

  would parse to

      (div
        (p "This is a " (a ((href "http://example.org")) "link") ".")
        ...)
  """
  (let ((acc (make-accumulator*)))
    (cond ((parse-markdown-source/metadata** #t acc fn)
           => (λ (parse-tree)
                (receive (parse-tree-result metadata/ignored)
                    (markdown:assemble-result parse-tree acc)
                  parse-tree-result)))
          (else #f))))

(define/provide (parse-markdown-string s)
  #"""`parse-markdown-string : string? -> list?` :
  Given a string, parse it as Markdown and return the parse-tree.

  See `parse-markdown-file`."""
  (let ((acc (make-accumulator*)))
    (cond ((parse-markdown-source/metadata** #f acc s)
           => (λ (parse-tree)
                (receive (parse-tree-result metadata/ignored)
                    (markdown:assemble-result parse-tree acc)
                  parse-tree-result)))
          (else #f))))

(define/provide (parse-markdown-file/metadata fn)
  #"""`parse-markdown-file/metadata : string? -> list? <opaque>` :
  Given a file containing Markdown, this parses it and returns
  the parse tree and metadata as multiple values.  The parse-tree is
  as described in `parse-markdown-file`,
  and the metadata is a structure which can be queried by `metadata/type`."""
  (let ((acc (make-accumulator*)))
    (markdown:assemble-result (parse-markdown-source/metadata** #t acc fn) acc)))

(define/provide (parse-markdown-string/metadata s)
  #"""`parse-markdown-string/metadata : string? -> list? <opaque>` :
  As with `parse-markdown-file/metadata`, but parsing the given string as Markdown."""
  (let ((acc (make-accumulator*)))
    (markdown:assemble-result (parse-markdown-source/metadata** #f acc s) acc)))

(define/provide (metadata/type metadata/list key)
  #"""`metadata/type : <opaque> symbol? -> <various>` :
  Given a metadata list returned from `parse-markdown-file/metadata`,
  extract the elements keyed by `key`.  The keys can be

    * 'citation : this returns a list of lists, where the car of
      each list is the content of a `[@cite]` key and the cadr is
      the `(cite ...)` element in the parsed tree which corresponds
      to it.
    * 'annotation : this is similarly a list of lists capturing
      key-value annotations within the Markdown (ie, `key: value`
      immediately after `----`).

  The content of both of these should currently be regarded as very
  much subject to change."""
  (fold (λ (el knil)
          (if (eqv? (car el) key)
              (cons (cdr el) knil)
              knil))
        '()
        metadata/list))

;; a couple of unused functions which reflect previous more-or-less
;; good ideas.

;; (define (markdown-metadata->citations metadata/list)
;;   #"""Given the metadata list returned from PARSE-MARKDOWN-FILE/METADATA,
;;   extract the 'citation elements, and return them as a hash-table
;;   (string? -> object), where the OBJECT is the (cite "foo") element in
;;   the associated parse-tree, which is therefore available for editing."""
;;   ;; metadata/list is a list of (symbol? any);
;;   ;; the 'citation elements of this are '(citation "key" obj)
;;   ;; where obj is a (cite "blah") object in the parse tree
;;   (apply hash-table
;;          (apply append
;;                 (map cdr
;;                      (filter (λ (k) (eqv? (car k) 'citation))
;;                              metadata/list)))))

;; MDINLINE:STRINGS-TO-PARAS : (listof string?) boolean? integer? -> (listof (p string?))
;; See parse-markdown.y.  The first argument is a list of strings
;; representing equally-indented lines; an included blank line is
;; represented by an empty string in the list.  Argument REVERSED?
;; indicates whether the lines are arriving in reverse order or not.
;; We split these into paragraphs separated by the empty strings, then
;; concatenate the strings into single ones, and run them through
;; parse-mdlnline.
;;
;; The result is a list of `(p "string")` elements.
;;
;; Argument LINENO is the line number which should be reported in
;; error messages; it's probably the line _after_ the paragraph we're processing.
;;
;; UNUSED RIGHT NOW...
;; (define (mdinline:strings-to-paras strings/list reversed? metadata lineno)
;;   (let loop ((ss (if reversed? strings/list (reverse strings/list)))
;;              (paras '())
;;              (this-para '()))
;;     (cond ((null? ss)
;;            (if (null? this-para)
;;                (map (lambda (content) (cons 'p content))
;;                     paras)
;;                (loop ss
;;                      (cons (parse-mdinline**
;;                             (string-join this-para " ")
;;                             metadata
;;                             lineno)
;;                            paras)
;;                      '())))
;;           ((string=? (car ss) "")       ;paragraph break
;;            (loop (cdr ss)
;;                  (cons (parse-mdinline**
;;                         (string-join this-para " ")
;;                         metadata
;;                         lineno)
;;                        paras)
;;                  '()))
;;           (else (loop (cdr ss) paras (cons (string-trim (car ss)) this-para))))))