Source

lowdown / lowdown.scm

Full commit
;; Inspired by:
;; https://github.com/jgm/peg-markdown/blob/master/markdown_parser.leg
;; https://github.com/jgm/pandoc/blob/master/src/Text/Pandoc/Readers/Markdown.hs

(module lowdown

(markdown->sxml markdown->sxml* markdown-sxml->html-sxml markdown->html)

(import chicken scheme)
(use data-structures srfi-1 clojurian-syntax comparse
     sxml-transforms lazy-seq lowdown-lolevel)

(define (maybe-ref key alist)
  (and-let* ((value (alist-ref key alist)))
    (and (not (and (not (car value))
                   (null? (cdr value))))
         value)))

(define (maybe-attr-ref attr attrs)
  (let ((value (maybe-ref attr attrs)))
    (if value
        (list (cons attr value))
        '())))

(define (reference-element? el)
  (and (pair? el) (eq? 'reference (car el))))

(define references
  (make-parameter #f))

(define (call-with-reference attrs proc)
  (let ((ref (-> (car (alist-ref 'ref attrs))
                 (alist-ref (references) equal?))))
    (if ref
        (proc ref attrs)
        (alist-ref 'input attrs))))

(define (make-image ref #!optional attrs)
  `(img (@ (src ,(alist-ref 'href ref))
           (alt . ,(alist-ref 'label (or attrs ref)))
           ,(if attrs
                (maybe-attr-ref 'title ref)
                `((title . ,(alist-ref 'title ref)))))))

(define (make-anchor ref #!optional attrs)
  `(a (@ (href ,(alist-ref 'href ref))
         . ,(maybe-attr-ref 'title ref))
      . ,(alist-ref 'label (or attrs ref))))

(define markdown-html-conversion-rules*
  `((explicit-link . ,(lambda (_ attrs)
                        (make-anchor attrs)))
    (reference-link . ,(lambda (_ attrs)
                         (call-with-reference attrs make-anchor)))
    (auto-link . ,(lambda (_ attrs)
                    `(a (@ (href . ,(alist-ref 'href attrs)))
                        . ,(alist-ref 'label attrs))))
    (image . ,(lambda (_ attrs)
                (make-image attrs)))
    (reference-image . ,(lambda (_ attrs)
                          (call-with-reference attrs make-image)))
    (verbatim . ,(lambda (_ contents)
                   `(pre (code . ,contents))))
    (bullet-list . ,(lambda (_ items)
                      `(ul . ,items)))
    (ordered-list . ,(lambda (_ items)
                       `(ol . ,items)))
    (item . ,(lambda (_ contents)
               `(li . ,contents)))
    (heading . ,(lambda (_ contents)
                  (cons (->> (number->string (car contents))
                             (string-append "h")
                             (string->symbol))
                        (cdr contents))))
    (paragraph . ,(lambda (_ contents)
                    `(p . ,contents)))
    (emphasis . ,(lambda (_ text)
                   `(em . ,text)))
    (strong . ,(lambda (_ text)
                 `(strong . ,text)))
    (html-element . ,(lambda (_ contents)
                       contents))
    (comment . ,(lambda (_ contents)
                  (list #\< "!--" contents "--" #\> #\newline)))
    (inline-note . ,(lambda (_ contents)
                      `(span (@ (class "note")) . ,contents)))
    . ,alist-conv-rules*))

(define (ref->alist-entry ref)
  (cons (car (alist-ref 'label (cdr ref)))
        (cdr ref)))

(define (markdown-sxml->html-sxml markdown-sxml)
  (receive (refs sxml) (partition reference-element? markdown-sxml)
    (parameterize ((references (map ref->alist-entry refs)))
      (pre-post-order* sxml markdown-html-conversion-rules*))))

(define (markdown->sxml* input)
  (parse document input))

(define (markdown->sxml input)
  (markdown-sxml->html-sxml (markdown->sxml* input)))

(define (markdown->html input)
  (-> (markdown->sxml input)
      (pre-post-order*  universal-conversion-rules*)
      (SRV:send-reply)))

)