~aasg/haunted-blog

bf9f9ed05b1bfd0a133423dc4acfbb477a9d015a — Aluísio Augusto Silva Gonçalves 1 year, 2 months ago faaf408
markdown: Expand heading attribute support
1 files changed, 33 insertions(+), 11 deletions(-)

M haunt.scm
M haunt.scm => haunt.scm +33 -11
@@ 16,6 16,7 @@
             (ice-9 match)
             (ice-9 regex)
             (ice-9 textual-ports)
             (ice-9 vlist)
             (srfi srfi-1)
             (srfi srfi-11)
             (srfi srfi-19)


@@ 204,6 205,11 @@

(define (transform-markdown-tree sxml)
  (define (parse-heading-attributes . sxml)
    ; Split heading attributes off the heading text proper.
    ; The heading text and a list of (unparsed) attributes are returned
    ; as multiple values.
    ;
    ; Note that spaces are not supported in values (even quoted ones).
    (define (extract-attributes str)
      (let ((match (string-match "[[:space:]]*\\{([^\\{\\}]*)\\}$" str)))
        (if match


@@ 211,19 217,35 @@
              (match:prefix match)
              (string-split (match:substring match 1) char-whitespace?))
            (values str '()))))
    (define (append-attribute str attrs)
      (let ((id (string-match "#([^[:space:]]+)" str))
            (class (string-match "\\.([^[:space:]]+)" str)))
        (append attrs (cond (id (list 'id (match:substring id 1)))
                            (class (list 'class (match:substring class 1)))
                            (else '())))))
    (define (deserialize-attribute-string str)
      (let-values (((before attrs) (extract-attributes str)))
        (values before (fold append-attribute '() attrs))))
    ; Parse a list of attributes and return a VHash mapping attribute
    ; keys to individual values.
    (define (build-attributes-dict attrs)
      (fold (lambda (attr attr-dict)
              (let ((id-match (string-match "#([^[:space:]]+)" attr))
                    (class-match (string-match "\\.([^[:space:]]+)" attr))
                    (kvu-match (string-match "([^\"'[:space:]=/>]+)=([^\"'[:space:]]+)" attr))
                    (kvs-match (string-match "([^\"'[:space:]=/>]+)='([^']+)'" attr))
                    (kvd-match (string-match "([^\"'[:space:]=/>]+)=\"([^']+)\"" attr)))
                (cond (id-match (vhash-consq 'id (match:substring id-match 1) attr-dict))
                      (class-match (vhash-consq 'class (match:substring class-match 1) attr-dict))
                      (kvu-match (vhash-consq (string->symbol (match:substring kvu-match 1)) (match:substring kvu-match 2) attr-dict))
                      (kvs-match (vhash-consq (string->symbol (match:substring kvs-match 1)) (match:substring kvs-match 2) attr-dict))
                      (kvd-match (vhash-consq (string->symbol (match:substring kvd-match 1)) (match:substring kvd-match 2) attr-dict))
                      (else attr-dict))))
            vlist-null
            attrs))
    ; Merge attributes with the same key in the VHash, concatenating
    ; repeated attributes with whitespace.  The result is a list of
    ; key-value lists (not pairs) so it can be fed directly to SXML.
    (define (fold-attributes-dict attr-dict)
      (map (lambda (key)
             (list key (string-join (vhash-foldq* cons '() key attr-dict) " ")))
           (vhash-fold (lambda (key _ prev-keys) (lset-adjoin eq? prev-keys key)) '() attr-dict)))
    (match sxml
           ((tag middle ... tail)
            (let*-values (((before attrs) (deserialize-attribute-string tail))
                          ((wrapped-attrs) (if (null? attrs) '() (list '@ attrs))))
            (let*-values (((before attrs) (extract-attributes tail))
                          ((parsed-attrs) (fold-attributes-dict (build-attributes-dict attrs)))
                          ((wrapped-attrs) (if (null? attrs) '() (cons '@ parsed-attrs))))
              `(,tag ,wrapped-attrs ,@middle ,before)))
           (_ sxml)))
  (define (remove-single-paragraphs-from-lists . sxml)