REBOL [
Title: "HTML Dialect"
Short: "HTML Dialect"
Author: ["Henrik Mikael Kristensen"]
Copyright: "2008 - HMK Design"
Filename: %html.r
Version: 0.0.3
Type: 'script
Maturity: 'unstable
Release: 'internal
Created: 13-Apr-2008
Date: 20-Jul-2008
License: {
BSD (www.opensource.org/licenses/bsd-license.php)
Use at your own risk.
}
Purpose: {
HTML dialect for simple generation of webpages with REBOL code.
}
Notes: {
Some problems with bindings in the TRAVERSE word.
Complex type sets in four places in the code.
Ugly binding in HTML-GEN.
}
Future: [
0.0.4 {
TEXT-GEN to convert HTML dialect to pure text.
Better practical use of the error log.
Attributes for form elements.
}
]
History: [
0.0.3 {
Automatic formatting of links via internal site links using AT PAGE.
Page list to manage internal site links
Path! added as cell-type
Simple error logging using LOG-ERROR.
Form rules for simple form generation and filling
Improved generation of content for HEAD such as META and LINK tags.
Sets end-slash for XHTML doctypes
}
0.0.2 {
Better separation of rules.
Renamed HTML-PARSE to HTML-GEN.
Direct support for more encompassing tags.
Tracks the current doctype with DOC-TYPE.
TAGs can be evaluated using the new EVAL-RULE.
END-TAG to complement TAG.
}
0.0.1 "First version"
]
Keywords: []
]
ctx-html: context [
set 'out-buffer ""
out: func [string [word! string! file! url! tag! number! time! date! block!]] [insert tail out-buffer reduce string] ; OK, but complex input
url-vars: []
url-var-string: make string! 1000
close-tag: func [word [word!]] [to-tag join "/" word]
res-tag: none
start-tag: []
end-tags: [] ; Track the historical use of end tags
pages: []
errors: []
current-page: none
refresh-time: 5 ; The number of seconds before a redirect page refreshes.
; ---------- Words used in dialect
head-block: []
end-tag: none ; name conflict with the word used in the dialect
vars: var-block: val: cell-val: tag-vals: form-tags: none
step: 1
form-object: none ; Managing form input via object
; possibly requiring string sanitation here
; form-value: func [word [word!]] [any [all [form-object in form-object word get in form-object word] all [value? word get word] ""]]
form-value: func [word [word!]] [
case [
all [form-object in form-object word] [get in form-object word]
all [value? word] [get word]
all [not value? word] [log-error ["Word" word "does not exist."] ""]
]
]
has-form-value: func [word [word!]] [
case [
all [form-object in form-object word] [true]
all [value? word not none? get word not series? get word] [true]
all [value? word series? get word] [not empty? get word]
all [value? word none? word] [false]
not value? word [log-error ["Word" word "does not exist."] false]
]
]
; ---------- URL Generation Functions
make-url-vars: func [vars /local v word] [
clear url-var-string
parse vars [any [set word any-word! (repend url-var-string [word "="]) set v any-type! (append url-var-string v)]]
]
page-link: func [
name [word!]
/local p
] [
unless p: find pages name [return log-error compose/deep [div error ["Page " (name) " does not exist"]]]
either current-page = name [p/3][make-url-vars clear url-vars compose/deep [tag [a href (append to-string p/2 url-var-string)] [(p/3)] end-tag]]
]
build-url: func [vars /local str w] [str: make string! "" parse vars [any [w: any-word! (repend str [w/1 "="]) any-type! (repend str [w/2 "&"])]] head remove back tail str]
; ---------- Misc Functions
text-gen: func [str] [str] ; pass through for now
log-error: func [str [string! block!]] [append errors text-gen reform str str] ; OK
; ---------- Types
cell-types: [set cell-val [block! | number! | date! | time! | word! | string! | path! | url! | get-word!]] ; Complex. Find common types to shorten this.
doc-types: [
html-2.0-dtd
html-3.2-dtd
html-4.01-strict
html-4.01-transitional
html-4.01-frameset
xhtml-1.0-strict
xhtml-1.0-transitional
xhtml-1.0-frameset
xhtml-1.0-dtd
xhtml-basic-1.0-dtd
xhtml-basic-1.1-dtd
xhtml-mathml-svg-dtd
svg-1.0-dtd
svg-1.1-full-dtd
svg-1.1-basic-dtd
svg-1.1-tiny-dtd
]
doc-type: none
doc-type-words: []
foreach [word tag] doc-types [repend doc-type-words [to-lit-word word '|]]
remove back tail doc-type-words
xhtml?: does [found? find to-string doc-type 'xhtml]
single-tags: [link meta img input frameset hr br]
; ---------- HTML Dialect Table Rules
; Rules for table row generation
table-row-rules: [
; tbody rules here
any [
'row (out )
any [
['cell (end-tag: 'td) | 'header (end-tag: 'th)] (insert clear start-tag end-tag)
; cell formatting
any [set type [['colspan set val integer! | 'align set val word! | 'width set val integer! opt ['percent (val: join val "%")]] | 'class set val word!] (repend start-tag [type val])]
; cell content
[none! (out build-tag start-tag) | cell-types (out build-tag start-tag html-gen cell-val)] (out close-tag end-tag)
] (out
)
]
]
table-cell-rule: [any [val: any-type! (html-gen compose/deep [td [(val/1)]])]]
table-row-rule: [val: any-type! (out [| ] html-gen val/1 out [ |
])]
; Using the formatted block. Only works with data as blocks of objects right now.
table-format-rules: [
any [
val: object! (parse bind format val/1 table-row-rules) ; block of objects.
| into [(out ) table-cell-rule (out
)] ; block of blocks. ignoring formatting here.
| table-row-rule ; block of single values. ignoring formatting here for later.
]
] ; per row
; Using no specific formatting, but simply produces one table cell per element in the block.
table-block-rules: [
any [
val: object! (out foreach cell next first val/1 [html-gen compose [td (get in val/1 cell)]] out
) ; block of objects
| into [(out ) table-cell-rule (out
)] ; block of blocks
| table-row-rule ; block of single values
]
]
; ---------- HTML Dialect Parse Rules
text-rules: ['html | 'head | 'title | 'body | 'p | 'strong | 'em | 'b | 'i | 'tt | 'pre | 'ul | 'il | 'li | 'sup | 'sub | 'tr | 'th | 'td | 'table | 'a | 'div | 'span] ; OK
data-rules: [[string! | tag! | number!] (out cmd/1) | block! (html-gen cmd/1)] ; OK
eval-rules: [any [val: ['do block! (insert tail eval-res do val/2) | any-type! (insert tail eval-res val/1)]]] ; OK
eval-res: make block! [] ; OK
tag-rules: [
'=== word! (tag-vals: "") opt ['opts block! (tag-vals: cmd/4)] cell-types (html-gen compose/deep [tag [(cmd/2) (tag-vals)] (cell-val) end-tag]) ; OK
| 'tag (clear eval-res) into eval-rules (res-tag: trim build-tag eval-res either find single-tags cmd/2/1 [if xhtml? [append res-tag " /"]][append end-tags cmd/2/1] out res-tag) ; OK
| 'line (html-gen [tag [hr]]) ; OK
| 'end-tag (out close-tag either block? last end-tags [first last end-tags][last end-tags] remove back tail end-tags) ; OK
| ['div | 'span] word! cell-types (html-gen compose/deep [=== (cmd/1) opts [class (cmd/2)] [(cell-val)]]) ; OK
| 'at [
'page word! (html-gen page-link cmd/3)
| set url cell-types cell-types (var-block: make block! []) any [
'vars vars: [block! | object! (vars: third vars/1) | get-word! (vars: get vars/1)] (append var-block vars)
| 'words [set words block! (parse words [any [set w word! (repend var-block [to-set-word w get w])]])]
] (unless empty? var-block [url: rejoin [url "?" build-url third make object! var-block]] html-gen compose/deep [tag [a href (url)] [(cmd/3)] end-tag])
] ; Testing. Complicated.
| 'do block! (html-gen do cmd/2) ; OK
| 'table word! (out build-tag [table class (cmd/2) cellspacing 0 cellpadding 0]) ; OK
any [
['rows [set val word! (parse get val table-block-rules) | into table-row-rules | into table-block-rules]] ; OK
| ['format set format block! 'rows [set val word! (parse get val table-format-rules) | into table-format-rules]] ; OK
] (out )
| text-rules cell-types (html-gen reduce ['=== cmd/1 cell-val]) ; OK
| 'loop integer! block! (loop cmd/2 [html-gen do cmd/3]) ; OK
| 'traverse 2 block! (repeat i length? cmd/2 [html-gen reduce bind cmd/3 cmd/2/:i]) ; Not OK. Bind problem.
]
; ---------- Form Functions and Rules
set-check-indicator: does [append last form-tags either xhtml? [[checked checked]]['checked]] ; OK
set-option-tag: func [block pos] [
case [
all [xhtml? same? block pos] [[=== option opts [selected selected] [(pick values i)]]]
all [same? block pos] [[=== option opts [selected] [(values/:i)]]]
true [[=== option [(values/:i)]]]
]
] ; OK
form-rules: [
[
'form cell-types
opt [[get-word! (vars: get cmd/3) | ['vars [block! (vars: make object! cmd/3) | object! (vars: cmd/3)]]] (form-object: vars)] cell-types
(form-tags: [=== form opts [action (cmd/2) method post] [(cell-val)]]) ; Testing
| 'textarea word! (form-tags: [tag [textarea name (cmd/2)] (form-value cmd/2) end-tag]) ; Testing
| ['field | 'button | 'hidden | 'password] word! (form-tags: [tag [input type (cmd/1) name (cmd/2) value (form-value cmd/2)]]) ; Testing
| 'checkbox word! (form-tags: copy/deep [tag [input type checkbox name (cmd/2)]] if has-form-value cmd/2 [set-check-indicator]) ; OK
| 'radio word! cell-types (form-tags: copy/deep [tag [input type radio name (cmd/2) value (cmd/3)]] if cmd/3 = form-value cmd/2 [set-check-indicator]) ; Testing
| 'select word! (form-tags: compose/deep [=== select opts [name (cmd/2)] []]) [
['values (step: 1) | 'key-values (step: 2) | (step: 1)]
cell-types (for i step length? values: head form-value cell-val step [append form-tags/5 compose/deep bind set-option-tag form-value cell-val at values i 'i])
] ; Testing
| ['submit | 'reset] string! (form-tags: [tag [input type (cmd/1) value (cmd/2)]]) ; Testing
] (html-gen compose/deep form-tags)
]
; ---------- Higher Level Rules
href-types: [word! | url! | string! | path! | refinement!] ; OK
to-head-block: func [data] [append head-block compose/deep [tag [(compose/deep data)]]] ; OK
page-rules: [
; clear out-buffer here?
'page cell-types (clear head-block) any [
val: [
'redirect href-types (to-head-block [meta http-equiv refresh content (rejoin [refresh-time "; url=" val/2])]) ; OK
| 'favicon href-types (to-head-block [link rel "shortcut icon" href (val/2)]) ; OK
| 'charset [string! | word!] (to-head-block [meta http-equiv content-type content (join "text/html; charset=" val/2)]) ; OK
| 'css href-types (to-head-block [link rel stylesheet href (val/2) type "text/css"]) ; OK
| 'script href-types (to-head-block [script src (val/2) type "text/javascript"]) ; OK
; add more types here
]
| 'meta ['name | 'http-equiv] 2 cell-types [to-head-block [meta (val/2) (val/3) content (val/4)]] ; OK
] val: block! (
html-gen compose/deep [
xhtml-1.0-strict ; should be changable
;html-4.01-strict ; activate this line when testing non-XHTML mode
html [head [(head-block) title [(cell-val)]] body [(val/1)]]
]
)
]
site-rules: ['name word! (current-page: cmd/2) | 'pages into [any [word! [url! | word!] string! (repend pages [cmd/2 cmd/3 cmd/4])]]] ; OK
error-rules: ['errors (print errors)] ; Should make this better
word-rules: [doc-type-words (out select doc-types doc-type: cmd/1) | word! (out cmd/1) | get-word! (out get cmd/1)] ; OK
set 'html-gen func [
"Low level HTML dialect"
data [none! object! string! tag! file! url! number! time! date! get-word! word! block!] ; Complex
/local cmd blk header row-blk start-tag ; check these
] compose/deep [
if get-word? data [data: get data] ; problem h
if any [file? data url? data string? data number? data word? data time? data date? data] [out data return true] ; Complex
if none? data [return true]
bind eval-rules 'data
parse data [any [cmd: [(data-rules) | (tag-rules) | (form-rules) | (page-rules) | (site-rules) | (error-rules) | (word-rules)]]]
]
]