Rebol [
    Title: "HTML Emitter"
    Type: 'emitter
    License: %license.r
]

with: func [
    "Binds and evaluates a block to a specified context."
    object [any-word! object! port!] "Target context."
    block [any-block!] "Block to be bound."
    /only "Returns the block unevaluated."
][
    block: bind block object
    either only [block] :block
]

press: :rejoin

;-- Helpers
feed: does [emit newline]

wrap: func [text [string! block!] tag [tag! none!]][
    either tag [
        insert text tag
        parse/all form tag ["<" tag: (insert tag "/") [to " " | to ">"] tag: (clear tag)]
        append text tag
    ][text]
]

to-attr: func ['attr [word!]][
    either get :attr [
        press [" " form attr {="} sanitize form get :attr {"}]
    ][""]
]

emit-smarttag: func [spec [block!] /local tag errs rel][
    errs: []
    unless switch take tag: copy spec [
        link [
            if tag: match tag [
                href: file! | url! | email!
                anchor: opt string!
                rel: opt get-word! is within [:flow :nofollow]
            ][
                with tag [
                    anchor: any [anchor form href]
                    if email? href [href: join #[url! "mailto:"] href]
                    emit ["<a" to-attr href to-attr rel ">" sanitize anchor </a>]
                ]
            ]
        ]
        wiki [
            if tag: match tag [
                href: string!
                anchor: opt string!
            ][
                with tag [
                    anchor: any [anchor href]
                    href: url-encode/wiki href
                    emit ["<a" to-attr href ">" sanitize anchor </a>]
                ]
            ]
        ]
        img image icon [
            either tag: match/report-to tag [
                src: file! | url! else "Image Tag Needs Valid Source"
                alt: string! else "Image tag requires ALT text"
                size: opt pair!
            ] errs [
                use [width height] with/only tag [
                    width: all [size/x > -1 size/x]
                    height: all [size/y > -1 size/y]
                    emit ["<img" to-attr src to-attr width to-attr height to-attr alt { class="icon" />}]
                ]
            ][
                foreach [key reasons] errs [
                    foreach reason reasons [
                        emit ["[" sanitize reason "]"]
                    ]
                ]
            ]
        ]
    ][
        emit {<span class="attention">!Unable to parse tag!</span>}
    ]
]

emit-image: func [spec [block!] /local out image][
    either image: match spec [
        src: file! | url!
        size: opt pair!
        alt: string!
        title: opt string!
        href: opt file! | url!
    ][
        out: copy []
        with image [
            src: to-attr src
            alt: to-attr alt
            title: to-attr title
            size: any [size -1x-1]
            width: either 0 > width: size/x [""][to-attr width]
            height: either 0 > height: size/y [""][to-attr height]
            repend out ["<img" width height src alt title " />"]
            if href [
                insert append out </a> reduce ["<a" to-attr href ">"]
            ]
        ]

        emit [{<div class="img">^/} press out {^/</div>}]
    ][
        raise ["Invalid Image Spec #" sanitize mold spec]
    ]
]

emit-video: func [spec [block!] /youtube /vimeo /local video][
    unless any [youtube vimeo][raise "Invalid Video Request" exit]

    either video: match spec [
        id: issue!
        ratio: opt pair! is within [16x9 4x3]
    ][
        video/id: join case [
            youtube [https://youtube.com/embed/]
            vimeo [http://player.vimeo.com/video/]
        ] sanitize video/id
        emit [{<div class="tube">^/<iframe type="text/html" src="} video/id {"></iframe>^/</div>}]
    ][
        raise ["Invalid Video Spec #" sanitize mold spec]
    ]
]

get-list-options: func [options [block!]][
    either options: match options [
        tag: opt 'bullets
        reversed: opt 'reversed
        start: opt integer! is more-than 0
    ][
        make options [
            end: either tag = 'bullets [
                tag: <ul> </ul>
            ][
                tag: to-tag rejoin ["ol" to-attr reversed to-attr start]
                </ol>
            ]
        ]
    ][
        context [tag: <ol> end: </ol> start: 1]
    ]
]

;-- Paragraph States
initial: [
    options: place: topics: ()
    ; para: (emit <p> emit-inline initialize data emit [</p> newline]) normal
    default:
        (emit "^/<!-- document begin -->")
        continue normal
        (emit "^/<!-- document end -->^/")
]

normal: [
    para: (feed emit <p> emit-inline data emit </p>)
    sect1: 
        (feed emit-sect 1 data unless no-indent [emit <section>])
        in-sect
        (unless no-indent [emit </section>])
    sect2:
        (feed emit-sect 2 data unless no-indent [emit <section>])
        in-sect
        (unless no-indent [emit </section>])
    sect3: (feed emit-sect 3 data)
    sect4: (feed emit-sect 4 data)
    bullet: bullet2: bullet3: (feed emit [<ul> newline <li>] emit-inline data) in-bul (emit [</li> newline </ul>])
    enum: enum2: enum3: (feed emit [<ol> newline <li>] emit-inline data) in-enum (emit [</li> newline </ol>])
    code: (feed emit [<pre><code> sanitize data </code></pre>])
    output: (feed emit data) ; to output html directly
    define-term: (feed emit <dl class="short">) continue in-deflist (feed emit </dl>)
    image: (feed emit <figure class="image">) continue media (feed emit </figure>)
    youtube: vimeo: (feed emit <figure class="media">) continue media (feed emit </figure>)
    break: (feed emit <hr />)
    figure-in: (feed emit <figure>) in-figure (feed emit </figure>)
    figure-out: (raise "Unbalanced Figure")
    sidebar-in: (feed emit <aside class="sidebar">) in-sidebar (feed emit </aside>)
    sidebar-out: (raise "Unbalanced Sidebar")
    table-in:
        (feed emit {<table><tr>^/<th>})
        table-header
        (feed emit {</td>^/</tr></table>})
    table-out: (raise "Unbalanced table-out")
    list-in:
        (
            options: get-list-options data
            feed emit [options/tag <li>]
            hold options
        )
        in-list
        (
            options: release
            feed emit [</li> options/end]
        )
    center-in:
        (feed emit <center>)
        in-center
        (feed emit </center>)
    center-out: (raise "Unbalanced center-out")
    note-in:
        (feed emit [<div class="note"><p><b>] emit-inline data emit [</b></p>])
        in-note
        (emit </div>)
    note-out: (raise "Unbalanced note-out")
    define-in:
        (feed emit [<dl><dt>] emit-inline data emit </dt> feed emit <dd>)
        in-define
        (feed emit [</dd></dl>])
    define-out: (raise "Unbalanced define-out")
    indent-in:
        (feed emit <div class="indented">)
        in-indent
        (feed emit </div>)
    indent-out: (raise "Unbalanced indent-out")
    column-in:
        (feed emit {<table><tr><td>})
        in-column
        (feed emit {</td></tr></table>})
    column-out: (raise "Unbalanced column-out")
    quote-in:
        (feed emit either find any [data []] 'pullquote [<blockquote class="pullquote">][<blockquote>])
        in-quote
        (feed emit </blockquote>)
    pullquote-in:
        (feed emit <blockquote class="pullquote">)
        in-pullquote
        (feed emit </blockquote>)
    column: (raise "column command not inside column group")
    group-in: in-group ; useless in normal mode, here just to enforce balanced commands
    group-out: (raise "Unbalanced Group-Out")
    ; default: (emit [<p> uppercase/part form word 1 " Unknown</p>"])
]

in-block: inherit normal [
    sect1: (feed emit <h1> emit-inline data emit </h1>)
    sect2: (feed emit <h2> emit-inline data emit </h2>)
]

in-list: inherit in-block [
    list-item: (feed emit {</li><li>})
    list-out: return
]

in-bul: [
    bullet: (emit [</li> newline <li>] emit-inline data)
    bullet2: (feed emit [<ul> newline <li>] emit-inline data) in-bul2 (emit [</li> newline </ul> newline])
    bullet3: (feed emit [<ul> newline <li>]) continue in-bul2 (emit [</li> newline </ul> newline])
    enum2: (feed emit [<ol> newline <li>] emit-inline data) in-enum2 (emit [</li> newline </ol> newline])
    enum3: (feed emit [<ol> newline <li>]) continue in-enum2 (emit [</li> newline </ol> newline])
    default: continue return
]

in-bul2: [
    bullet2: (feed emit [</li> newline <li>] emit-inline data)
    bullet3: (feed emit <ul>) continue in-bul3 (feed emit </ul>)
    enum3: (feed emit <ol>) continue in-enum3 (feed emit </ol>)
    default: continue return
]

in-bul3: [
    bullet3: (feed emit <li> emit-inline data emit </li>)
    default: continue return
]

in-enum: [
    enum: (emit [</li> newline <li>] emit-inline data)
    bullet2: (feed emit [<ul> newline <li>] emit-inline data) in-bul2 (emit [</li> newline </ul> newline])
    bullet3: (feed emit [<ul> newline <li>]) continue in-bul2 (emit [</li> newline </ul> newline])
    enum2: (feed emit [<ol> newline <li>] emit-inline data) in-enum2 (emit [</li> newline </ol> newline])
    enum3: (feed emit [<ol> newline <li>]) continue in-enum2 (emit [</li> newline </ol> newline])
    default: continue return
]

in-enum2: [
    enum2: (emit [</li> newline <li>] emit-inline data)
    bullet3: (feed emit <ul>) continue in-bul3 (feed emit [</ul> newline])
    enum3: (feed emit <ol>) continue in-enum3 (feed emit [</ol> newline])
    default: continue return
]

in-enum3: [
    enum3: (feed emit <li> emit-inline data emit </li>)
    default: continue return
]

in-deflist: [
    define-term: (feed emit <dt> emit-inline data emit </dt>)
    define-desc: (feed emit <dd> emit-inline data emit </dd>)
    default: continue return
]

table-header: inherit in-block [
    table-out: return
    table-row: (emit "</th>^/</tr><tr><td>") table-rows
    column: (emit "</th>^/<th>")
]

table-rows: inherit in-block [
    table-out: continue return ; back to table-header which goes back to caller
    table-row: (emit "</td>^/</tr><tr><td>") table-rows
    column: (emit "</td>^/<td>")
]

in-table-define: [
    define-desc: (emit <dd> emit-inline data emit "</dd>^/") return
]

in-group: inherit normal [
    sect1: sect2: (raise "No Headings In Here!")
    group-out: return
]

in-center: inherit in-block [
    center-out: return
]

media: [
    youtube: (feed emit-video/youtube data) return
    vimeo: (feed emit-video/vimeo data) return
    image: (feed emit-image data) return
]

in-figure: [
    image: youtube: vimeo: continue media
    para: (feed emit <figcaption> emit-inline data emit </figcaption>)
    group-in: (feed emit <figcaption>) in-group (feed emit </figcaption>)
    default: (raise "Content Misplaced in Figure")
    figure-out: return
]

in-sidebar: inherit in-block [
    sidebar-out: return
]

in-note: inherit in-block [
    sect1: sect2: (raise "No Headings In Here!")
    note-out: return
]

in-quote: inherit in-block [
    quote-out: (if data [emit [<h4> data </h4>]]) return
]

in-pullquote: inherit in-block [
    pullquote-out: return
]

in-define: inherit in-block [
    define-out: return
]

in-indent: inherit in-block [
    indent-out: return
]

in-column: inherit in-block [
    column-out: return
    column: (emit {^/</td><td valign=top>^/})
]

in-sect: inherit normal [
    sect1: sect2: continue return ; pop out of the <indent>
]

;-- Inline States
inline: [
    <p> ()
    default: continue paragraph
]

paragraph: [
    :string! (emit value)
    <b> (emit <b>) in-bold (emit </b>)
    <i> (emit <i>) in-italic (emit </i>)
    <q> (emit <q>) in-qte (emit </q>)
    <dfn> (emit <dfn>) in-dfn (emit </dfn>)
    <del> (emit <del>) in-del (emit </del>)
    <ins> (emit <ins>) in-ins (emit </ins>)
    <cite> (emit <cite>) in-cite (emit </cite>)
    <code> <var> (emit <var>) in-code (emit </var>)
    <initial> (emit <span class="initial">) in-initial (emit </span>)
    <br/> <br /> (emit <br/>)
    :integer! :char! (emit ["&#" to-integer value ";"])
    </> ()
    :block! (emit-smarttag value)
    default: "[???]"
]

in-bold: inherit paragraph [</b> return </> continue return]

in-italic: inherit paragraph [</i> return </> continue return]

in-qte: inherit paragraph [</q> return </> continue return]

in-dfn: inherit paragraph [</dfn> return </> continue return]

in-del: inherit paragraph [</del> return </> continue return]

in-ins: inherit paragraph [</ins> return </> continue return]

in-cite: inherit paragraph [</cite> return </> continue return]

in-code: inherit paragraph [</var> </code> return </> continue return]

in-initial: inherit paragraph [</initial> return </> continue return]