md.reb

REBOL[
    Title: "Rebol Markdown Parser"
    File: %md.reb
    Author: "Boleslav Březovský"
    Date: 7-3-2014
    Type: 'module
    Exports: [markdown]
    Options: [isolate]
    To-do: [
        "function to produce rule wheter to continue on start-para or not"
    ]
    Known-bugs: [
    ]
    Notes: ["For mardown specification, see http://johnmacfarlane.net/babelmark2/faq.html"]
]

xml?: true
start-para?: true
end-para?: true
md-buffer: null

; Modern Ren-C doesn't emit tags as-text, they're formatting instructions
; in things like PRINT.  So we can't use UNSPACED.  Redo AJOIN here as a
; version that turns tags to plain strings
;
ajoin: func [block [block!] <local> out] [
    out: copy block
    for-next 'pos out [
        if tag? pos.1 [change pos form pos.1]
    ]
    return unspaced out
]


; FIXME: hacky switch to determine wheter to emit <p> or not (for snippets)

para?: false

set [open-para close-para] either para? [[<p></p>]][["" ""]]

; -----

value: copy "" ; FIXME: leak?

emit: func [data] [
;    print "***wrong emit***"
    append md-buffer data
]
close-tag: func [tag] [head insert copy tag #"/"]

start-para: does [
    if start-para? [
        start-para?: false
        end-para?: true
        emit open-para
    ]
]

entities: [
    #"<" (emit "&lt;")
|    #">" (emit "&gt;")
|    #"&" (emit "&amp;")
]
escape-set: charset "\`*_{}[]()#+-.!"
escapes: use [escape] [
    [
        #"\"
        (start-para)
        set escape escape-set
        (emit escape)
    ]
]
numbers: charset [#"0" - #"9"]
; some "longer, but readable" stuff
plus: #"+"
minus: #"-"
asterisk: #"*"
underscore: #"_"
hash: #"#"
dot: #"."
eq: #"="
lt: #"<"
gt: #">"

header-underscore: use [text tag] [
    [
        copy text to newline
        newline
        some [eq (tag: <h1>) | minus (tag: <h2>)]
        [newline | end]
        (
            end-para?: false
            start-para?: true
            emit ajoin [tag text close-tag tag]
        )
    ]
]

header-hash: use [value continue trailing mark tag] [
    [
        (
            continue: either start-para? [[not space]] [[fail]]
            mark: ""
        )
        continue
        copy mark some hash
        space
        (emit tag: to tag! compose [h (length? mark)])
        some [
            [
                (trailing: "")
                [[any space mark] | [opt [2 space (trailing: join newline newline)]]]
                [newline | end]
                (end-para?: false)
                (start-para?: true)
                (emit ajoin [close-tag tag trailing])
            ]
            break
        |    set value skip (emit value)
        ]
    ]
]

entity-rule: [
    start:
    "&"
    [
        "#8203"
    |    "nbsp"
    |    "larr"
    |    "rarr"
    |    "darr"
    |    "uarr"
    |    "times"
    |    "delta"
    |    "amp"
    |    "aacute"
    |    "iquest"
    |    "asymp"
    ]
    ";"
    finish:
    (emit copy:part start finish)
]

tag-rule: [
    start:
    "<"
    opt "/"
    [
        "br"
    |    "sup"
    |    "sub"
    |    "i"
    |    "b"
    |    "em"
    |    "strong"
    |    "strike"
    ]
    ">"
    finish:
    (emit copy:part start finish)
]

header-rule: [
    header-underscore
|    header-hash
]

;autolink-rule: use [address] [
;    [
;        lt
;        copy address ; TODO: Parse address to match email
;        to gt skip
;        (
;            start-para
;            emit ajoin [-{<a href="}- address -{">}- address </a>]
;        )
;    ]
;]

link-rule: use [text address value title] [
    [
        #"["
        copy text
        to #"]" skip
        #"("
        (
            address: copy ""
            title: null
        )
        any [
            not [space | tab | #")"]
            set value skip
            (append address value)
        ]
        opt [
            some [space | tab]
            #"^""
            copy title to #"^""
            skip
        ]
        skip
        (
            ; While ( and ) are technically legal in URL!, they make MarkDown
            ; confusing.
            ;
            ; https://stackoverflow.com/q/13824669/#comment86250449_40076454
            ;
            if any [
                find address "("
                find address ")"
            ][
                print address
                fail "( or ) in markdown URL, use %28 and %29"
            ]
            start-para
            title: either title [ajoin [space -{title="}- title -{"}-]][""]
            emit ajoin [
                -{<a href="}- address -{"}- title -{>}-
                either xml? [markdown/xml text] [markdown text]
                </a>
            ]
        )
    ]
]

em-rule: use [mark text] [
    [
        copy mark ["**" | "__" | "*" | "_"]
        not space
        copy text
        to mark mark
        (
            start-para
            mark: either equal? length? mark 1 [<em>] [<strong>]
            emit ajoin [
                mark
                either xml? [markdown:xml text] [markdown text]
                close-tag mark
            ]
        )
    ]
]

img-rule: use [text address] [
    [
        #"!"
        #"["
        copy text
        to #"]" skip
        #"("
        copy address
        to #")" skip
        (
            start-para
            emit ajoin [
                -{<img src="}- address -{" alt="}- text -{"}-
                    either xml? -{ />}- -{>}-
            ]
        )
    ]
]

; TODO: make it bitset!
horizontal-mark: [minus | asterisk | underscore]

horizontal-rule: [
    horizontal-mark
    any space
    horizontal-mark
    any space
    horizontal-mark
    any [
        horizontal-mark
    |    space
    ]
    (
        end-para?: false
        emit either xml? <hr /><hr>
    )
]

unordered: [any space [asterisk | plus | minus] space]
ordered: [any space some numbers dot space]

; TODO: recursion for lists

list-rule: use [continue tag item] [
    [
        some [
            (
                continue: either start-para? [
                    [
                        ordered (item: ordered tag: <ol>)
                    |    unordered (item: unordered tag: <ul>)
                    ]
                ] [
                    [fail]
                ]
            )
            continue
            (start-para?: end-para?: false)
            (emit ajoin [tag newline <li>])
            line-rules
            newline
            (emit ajoin [</li> newline])
            some [
                item
                (emit <li>)
                line-rules
                [newline | end]
                (emit ajoin [</li> newline])
            ]
            (emit close-tag tag)
        ]
    ]
]

blockquote-rule: use [continue] [
    [
        (
            continue: either start-para? [[gt any space]] [[fail]]
        )
        continue
        (emit ajoin [<blockquote> newline])
        line-rules
        [[newline (emit newline)] | end]
        any [
            ; FIXME: what an ugly hack
            [newline ] (remove back tail md-buffer emit ajoin [close-para newline newline open-para])
        |    [
                continue
                opt line-rules
                [newline (emit newline) | end]
            ]
        ]
        (end-para?: false)
        (emit ajoin [close-para newline </blockquote>])
    ]
]

inline-code-rule: use [code value] [
    [
        [
            "``"
            (start-para)
            (emit <code>)
            some [
                "``" (emit </code>) break ; end rule
            |    entities
            |    set value skip (emit value)
            ]
        ]
    |    [
            "`"
            (start-para)
            (emit <code>)
            some [
                "`" (emit </code>) break ; end rule
            |    entities
            |    set value skip (emit value)
            ]
        ]
    ]
]

code-line: use [value][
    [
        some [
            entities
        |    [newline | end] (emit newline) break
        |    set value skip (emit value)
        ]
    ]
]

code-rule: use [text] [
    [
        [4 space | tab]
        (emit ajoin [<pre><code>])
        code-line
        any [
            [4 space | tab]
            code-line
        ]
        (emit ajoin [</code></pre>])
        (end-para?: false)
    ]
]

asterisk-rule: ["\*" (emit "*")]

newline-rule: [
    newline
    any [space | tab]
    some newline
    any [space | tab]
    (
        emit ajoin [close-para newline newline]
        start-para?: true
    )
|    newline (emit newline)
]

line-break-rule: [
    space
    some space
    newline
    (emit ajoin [either xml? [<br />] [<br>] newline])
]

leading-spaces: use [continue] [
    [
        (continue: either start-para? [[some space]] [[fail]])
        continue
        (start-para)
    ]
]

; simplified rules used as sub-rule in some rules

line-rules: [
    some [
        em-rule
    |    link-rule
    |    header-rule
    |    not newline set value skip (
        start-para
        emit value
    )
    ]
]

; main rules

rules: [
;    any space
    some [
        entity-rule
    |    tag-rule
    |    header-rule
    |    link-rule
;    |    autolink-rule
    |    img-rule
    |    list-rule
    |    blockquote-rule
    |    inline-code-rule
    |    code-rule
    |    asterisk-rule
    |    em-rule
    |    entities
    |    escapes
    |    line-break-rule
    |    newline-rule
    |    end (if end-para? [end-para?: false emit close-para])
    |    leading-spaces
    |    set value skip (
            start-para
            emit value
        )
    ]
]

markdown: func [
    "Parse markdown source to HTML or XHTML"
    data
    ; TODO:
    /into out [any-string!]
    /only "Return result without newlines"
    ; TODO:
    /xml "Switch from HTML tags to XML tags (e.g.: <hr /> instead of <hr>)"
    /local old-md-buffer
] [
    old-start-para?: start-para?
    old-end-para?: end-para?
    old-para?: para?
    old-md-buffer: md-buffer

    start-para?: true
    end-para?: true
    para?: false
    md-buffer: either into [out] [copy ""]

;    probe rules
    parse/redbol data [some rules]

    start-para?: old-start-para?
    end-para?: old-end-para?
    para?: old-para?
    md-buffer elide (md-buffer: old-md-buffer)
]