Source

lowdown / lowdown.scm

;; 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
 markdown-html-conversion-rules*)

(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*
  (make-parameter
   `((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)))
     . ,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* #!optional (input (current-input-port)) (memoize? #t))
  (parse document input memoize: memoize?))

(define (markdown->sxml #!optional (input (current-input-port)) (memoize? #t))
  (receive (result remainder)
      (markdown->sxml* input memoize?)
    (values (markdown-sxml->html-sxml result) remainder)))

(define (markdown->html #!optional (input (current-input-port)) (memoize? #t))
  (receive (result remainder)
      (markdown->sxml input memoize?)
    (values (-> result
                (pre-post-order* universal-conversion-rules*)
                (SRV:send-reply))
            remainder)))

)
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.