Welcome to the CHICKEN Scheme pasting service

(use lowdown sxml-transforms)

(define document
  "hello [world](http://world.com).\n\nhey, what's up?\n\nbla")

(let ((result (markdown->sxml document)))
  (newline)
  (pp result)
  (SRV:send-reply (pre-post-order result universal-conversion-rules))
  (newline))

;; $ csi -s tests/run.scm 
;;
;; ((p "hello" #\space (a (@ (href "http://world.com")) "world") ".")
;;  (p "hey," #\space "what" #\' "s" #\space "up?")
;;  (p "bla"))
;;
;; <p>hello <a href="http://world.com">world</a>.</p>
;; <p>hey, what's up?</p>
;; <p>bla</p>

;; 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)

(import chicken scheme)
(use comparse)
(use srfi-14 clojurian-syntax latch)

(define (enclosed open content close)
  (sequence* ((_ open) (return content) (_ close))
    (result return)))

(define (node el parser)
  (sequence* ((content parser))
    (result (cons el content))))

(define end-of-input
  (none-of item))

(define space-chars
  (char-set #\space #\tab))

(define space-char
  (satisfies space-chars))

(define space*
  (zero-or-more space-char))

(define space+
  (sequence (one-or-more space-char)
            (result #\space)))

(define new-line
  (is #\newline))

(define normal-line-end
  (sequence space* new-line))

(define terminal-line-end
  (sequence space* new-line end-of-input))

(define line-break
  (sequence (char-seq "  ") normal-line-end (result '(br))))

(define line-end
  (first-of line-break
            terminal-line-end
            normal-line-end))

(define blank-line
  (sequence space* new-line))

(define non-indent-space
  (repeated (is #\space) max: 3))

(define special-chars
  (char-set #\* #\_ #\`
            #\& #\[ #\]
            #\( #\) #\<
            #\! #\# #\\
            #\' #\| #\"))

(define special-char
  (satisfies special-chars))

(define normal-chars
  (char-set-complement!
   (char-set-union
    special-chars
    space-chars
    (char-set #\newline))))

(define normal-char
  (satisfies normal-chars))

(define parentheses
  (satisfies (char-set #\( #\))))

(define non-space-char
  (sequence (none-of space-char new-line) item))

(define-syntax mutually-recursive-parser
  (syntax-rules ()
    ((_ body ...)
     (lambda ()
       (lambda (input)
         (let-once ((parser (begin body ...)))
                   (parser input)))))))

(define link
  (mutually-recursive-parser
   (sequence*
       ((label (enclosed (is #\[)
                         (-> (none-of (is #\]))
                             (sequence inline)
                             (zero-or-more))
                         (is #\])))
        (_ space*)
        (href (enclosed (is #\()
                        (-> (none-of parentheses)
                            (sequence non-space-char)
                            (zero-or-more)
                            (as-string))
                        (is #\)))))
     (result `(a (@ (href ,href)) . ,label)))))

(define inline
  (first-of (as-string (one-or-more normal-char))
            line-end
            space+
            (link)
            special-char))


(define inline-without-line-end
  (sequence (none-of line-end) inline))

(define inlines
  (one-or-more
   (first-of inline-without-line-end
             (followed-by line-end
                          inline-without-line-end))))

(define paragraph
  (enclosed non-indent-space
            (node 'p inlines)
            (one-or-more blank-line)))

(define plain
  (node 'p inlines))

(define block
  (sequence
    (zero-or-more blank-line)
    (first-of paragraph
              plain)))

(define doc
  (zero-or-more block))

(define (markdown->sxml input)
  (receive (result _) (parse doc input)
    (and result (car result))))

)