diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/library/lux/data/format/html.lux | 563 |
1 files changed, 563 insertions, 0 deletions
diff --git a/stdlib/source/library/lux/data/format/html.lux b/stdlib/source/library/lux/data/format/html.lux new file mode 100644 index 000000000..6a8e0b24f --- /dev/null +++ b/stdlib/source/library/lux/data/format/html.lux @@ -0,0 +1,563 @@ +(.module: + [library + [lux (#- Meta Source comment and) + ["." function] + [data + ["." product] + ["." maybe ("#\." functor)] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [type + abstract] + [host + ["." js]] + [macro + ["." template]] + [world + [net (#+ URL)]]]] + [// + [css + ["." selector] + ["." style (#+ Style)]] + ["." xml (#+ XML)]]) + +(type: #export Tag selector.Tag) +(type: #export ID selector.ID) +(type: #export Class selector.Class) + +(type: #export Attributes + {#.doc "Attributes for an HTML tag."} + (List [Text Text])) + +(type: #export Script js.Statement) + +(type: #export Target + #Blank + #Parent + #Self + #Top + (#Frame Text)) + +(def: (target value) + (-> Target Text) + (case value + #Blank "_blank" + #Parent "_parent" + #Self "_self" + #Top "_top" + (#Frame name) name)) + +(def: sanitize + {#.doc "Properly formats text to ensure no injection can happen on the HTML."} + (-> Text Text) + (|>> (text.replace-all "&" "&") + (text.replace-all "<" "<") + (text.replace-all ">" ">") + (text.replace-all text.double-quote """) + (text.replace-all "'" "'") + (text.replace-all "/" "/"))) + +(def: attributes + (-> Attributes Text) + (|>> (list\map (function (_ [key val]) + (format key "=" text.double-quote (..sanitize val) text.double-quote))) + (text.join-with " "))) + +(def: (open tag attributes) + (-> Tag Attributes Text) + (|> attributes + ..attributes + (format tag " ") + (text.enclose ["<" ">"]))) + +(def: close + (-> Tag Text) + (text.enclose ["</" ">"])) + +(abstract: #export (HTML brand) + Text + + (template [<name> <brand>] + [(abstract: #export <brand> Any) + (type: #export <name> (HTML <brand>))] + + [Meta Meta'] + [Head Head'] + [Item Item'] + [Option Option'] + [Input Input'] + [Cell Cell'] + [Header Header'] + [Row Row'] + [Column Column'] + [Parameter Parameter'] + [Body Body'] + [Document Document'] + ) + + (template [<super> <super-raw> <sub>+] + [(abstract: #export (<super-raw> brand) Any) + (type: #export <super> (HTML (<super-raw> Any))) + + (`` (template [<sub> <sub-raw>] + [(abstract: #export <sub-raw> Any) + (type: #export <sub> (HTML (<super-raw> <sub-raw>)))] + + (~~ (template.splice <sub>+))))] + + [Element Element' + [[Content Content'] + [Image Image']]] + + [Media Media' + [[Source Source'] + [Track Track']]] + ) + + (def: #export html + (-> Document Text) + (|>> :representation)) + + (def: #export (and pre post) + (All [brand] (-> (HTML brand) (HTML brand) (HTML brand))) + (:abstraction (format (:representation pre) (:representation post)))) + + (def: #export (comment content node) + (All [brand] (-> Text (HTML brand) (HTML brand))) + (:abstraction + (format (text.enclose ["<!--" "-->"] content) + (:representation node)))) + + (def: (empty name attributes) + (-> Tag Attributes HTML) + (:abstraction + (format (..open name attributes) + (..close name)))) + + (def: (simple tag attributes) + (-> Tag Attributes HTML) + (|> attributes + (..open tag) + :abstraction)) + + (def: (tag name attributes content) + (-> Tag Attributes (HTML Any) HTML) + (:abstraction + (format (..open name attributes) + (:representation content) + (..close name)))) + + (def: (raw tag attributes content) + (-> Text Attributes Text HTML) + (:abstraction + (format (..open tag attributes) + content + (..close tag)))) + + (template [<name> <tag> <brand>] + [(def: #export <name> + (-> Attributes <brand>) + (..simple <tag>))] + + [link "link" Meta] + [meta "meta" Meta] + [input "input" Input] + [embedded "embed" Element] + [column "col" Column] + [parameter "param" Parameter] + ) + + (def: #export (base href target) + (-> URL (Maybe Target) Meta) + (let [partial (list ["href" href]) + full (case target + (#.Some target) + (list& ["target" (..target target)] partial) + + #.None + partial)] + (..simple "base" full))) + + (def: #export style + (-> Style Meta) + (|>> style.inline (..raw "style" (list)))) + + (def: #export (script attributes inline) + (-> Attributes (Maybe Script) Meta) + (|> inline + (maybe\map js.code) + (maybe.default "") + (..raw "script" attributes))) + + (def: #export text + (-> Text Content) + (|>> ..sanitize + :abstraction)) + + (template [<tag> <alias> <name>] + [(def: #export <name> + Element + (..simple <tag> (list))) + + (def: #export <alias> <name>)] + ["br" br line-break] + ["wbr" wbr word-break] + ["hr" hr separator] + ) + + (def: #export (image source attributes) + (-> URL Attributes Image) + (|> attributes + (#.Cons ["src" source]) + (..simple "img"))) + + (def: #export (svg attributes content) + (-> Attributes XML Element) + (|> content + (\ xml.codec encode) + (..raw "svg" attributes))) + + (type: #export Coord + {#horizontal Nat + #vertical Nat}) + + (def: metric-separator ",") + (def: coord-separator ",") + + (def: (%coord [horizontal vertical]) + (Format Coord) + (format (%.nat horizontal) ..metric-separator (%.nat vertical))) + + (type: #export Rectangle + {#start Coord + #end Coord}) + + (type: #export Circle + {#center Coord + #radius Nat}) + + (type: #export Polygon + {#first Coord + #second Coord + #third Coord + #extra (List Coord)}) + + (def: (%rectangle [start end]) + (Format Rectangle) + (format (%coord start) ..coord-separator (%coord end))) + + (def: (%circle [center radius]) + (Format Circle) + (format (%coord center) ..metric-separator (%.nat radius))) + + (def: (%polygon [first second third extra]) + (Format Polygon) + (|> (list& first second third extra) + (list\map %coord) + (text.join-with ..coord-separator))) + + (type: #export Shape + (#Rectangle Rectangle) + (#Circle Circle) + (#Polygon Polygon)) + + (template [<name> <shape> <type> <format>] + [(def: (<name> attributes shape) + (-> Attributes <type> (HTML Any)) + (..simple "area" (list& ["shape" <shape>] + ["coords" (<format> shape)] + attributes)))] + + [rectangle "rect" Rectangle ..%rectangle] + [circle "circle" Circle ..%circle] + [polygon "poly" Polygon ..%polygon] + ) + + (def: (area attributes shape) + (-> Attributes Shape (HTML Any)) + (case shape + (#Rectangle rectangle) + (..rectangle attributes rectangle) + + (#Circle circle) + (..circle attributes circle) + + (#Polygon polygon) + (..polygon attributes polygon))) + + (def: #export (map attributes areas for) + (-> Attributes (List [Attributes Shape]) Image Image) + ($_ ..and + for + (case (list\map (product.uncurry ..area) areas) + #.Nil + (..empty "map" attributes) + + (#.Cons head tail) + (..tag "map" attributes + (list\fold (function.flip ..and) head tail))))) + + (template [<name> <tag> <type>] + [(def: #export <name> + (-> Attributes <type>) + (..empty <tag>))] + + [canvas "canvas" Element] + [progress "progress" Element] + [output "output" Input] + [source "source" Source] + [track "track" Track] + ) + + (template [<name> <tag>] + [(def: #export (<name> attributes media on-unsupported) + (-> Attributes Media (Maybe Content) Element) + (..tag <tag> attributes + (|> on-unsupported + (maybe.default (..text "")) + (..and media))))] + + [audio "audio"] + [video "video"] + ) + + (def: #export (picture attributes sources image) + (-> Attributes Source Image Element) + (..tag "picture" attributes (..and sources image))) + + (def: #export (anchor href attributes content) + (-> URL Attributes Element Element) + (..tag "a" (list& ["href" href] attributes) content)) + + (def: #export label + (-> ID Input) + (|>> ["for"] list (..empty "label"))) + + (template [<name> <container-tag> <description-tag> <type>] + [(def: #export (<name> description attributes content) + (-> (Maybe Content) Attributes <type> <type>) + (..tag <container-tag> attributes + (case description + (#.Some description) + ($_ ..and + (..tag <description-tag> (list) description) + content) + + #.None + content)))] + + [details "details" "summary" Element] + [field-set "fieldset" "legend" Input] + [figure "figure" "figcaption" Element] + ) + + (template [<name> <tag> <type>] + [(def: #export (<name> attributes content) + (-> Attributes (Maybe Content) <type>) + (|> content + (maybe.default (..text "")) + (..tag <tag> attributes)))] + + [text-area "textarea" Input] + [iframe "iframe" Element] + ) + + (type: #export Phrase (-> Attributes Content Element)) + + (template [<name> <tag>] + [(def: #export <name> + Phrase + (..tag <tag>))] + + [abbrebiation "abbr"] + [block-quote "blockquote"] + [bold "b"] + [cite "cite"] + [code "code"] + [definition "dfn"] + [deleted "del"] + [emphasized "em"] + [h1 "h1"] + [h2 "h2"] + [h3 "h3"] + [h4 "h4"] + [h5 "h5"] + [h6 "h6"] + [inserted "ins"] + [italic "i"] + [keyboard "kbd"] + [marked "mark"] + [meter "meter"] + [pre "pre"] + [quote "q"] + [sample "samp"] + [struck "s"] + [small "small"] + [sub "sub"] + [super "sup"] + [strong "strong"] + [time "time"] + [underlined "u"] + [variable "var"] + ) + + (def: #export incorrect ..struck) + + (def: (ruby-pronunciation pronunciation) + (-> Content (HTML Any)) + (..tag "rt" (list) + ($_ ..and + (..tag "rp" (list) (..text "(")) + pronunciation + (..tag "rp" (list) (..text ")"))))) + + (def: #export (ruby attributes content pronunciation) + (-> Attributes Content Content Element) + (..tag "ruby" attributes + ($_ ..and + content + (ruby-pronunciation pronunciation)))) + + (type: #export Composite (-> Attributes Element Element)) + + (template [<name> <tag>] + [(def: #export <name> + Composite + (..tag <tag>))] + + [article "article"] + [aside "aside"] + [dialog "dialog"] + [div "div"] + [footer "footer"] + [header "header"] + [main "main"] + [navigation "nav"] + [paragraph "p"] + [section "section"] + [span "span"] + ) + + (template [<tag> <name> <input>] + [(def: <name> + (-> <input> (HTML Any)) + (..tag <tag> (list)))] + + ["dt" term Content] + ["dd" description Element] + ) + + (def: #export (description-list attributes descriptions) + (-> Attributes (List [Content Element]) Element) + (case (list\map (function (_ [term description]) + ($_ ..and + (..term term) + (..description description))) + descriptions) + #.Nil + (..empty "dl" attributes) + + (#.Cons head tail) + (..tag "dl" attributes + (list\fold (function.flip ..and) head tail)))) + + (def: #export p ..paragraph) + + (template [<name> <tag> <input> <output>] + [(def: #export <name> + (-> Attributes <input> <output>) + (..tag <tag>))] + + [button "button" Element Input] + [item "li" Element Item] + [ordered-list "ol" Item Element] + [unordered-list "ul" Item Element] + [option "option" Content Option] + [option-group "optgroup" Option Option] + [data-list "datalist" Option Element] + [select "select" Option Input] + [address "address" Element Element] + [form "form" Input Element] + [data "data" Element Element] + [object "object" Parameter Element] + ) + + (template [<name> <tag> <input> <output>] + [(def: #export <name> + (-> <input> <output>) + (..tag <tag> (list)))] + + [title "title" Content Meta] + [no-script "noscript" Content Meta] + [template "template" (HTML Any) (HTML Nothing)] + [table-header "th" Element Header] + [table-cell "td" Element Cell] + [head "head" Meta Head] + [body "body" Element Body] + ) + + (template [<name> <tag> <input> <output>] + [(def: <name> + (-> <input> <output>) + (..tag <tag> (list)))] + + [table-row "tr" (HTML Any) Row] + [table-head "thead" Row HTML] + [table-body "tbody" Row HTML] + [table-foot "tfoot" Row HTML] + [columns-group "colgroup" Column HTML] + ) + + (def: #export (table attributes caption columns headers rows footer) + (-> Attributes (Maybe Content) (Maybe Column) Header (List Cell) (Maybe Cell) Element) + (let [head (..table-head (..table-row headers)) + content (case (list\map table-row rows) + #.Nil + head + + (#.Cons first rest) + (..and head + (..table-body + (list\fold (function.flip ..and) first rest)))) + content (case footer + #.None + content + + (#.Some footer) + (..and content + (..table-foot (..table-row footer)))) + content (case columns + #.None + content + + (#.Some columns) + (..and (..columns-group columns) + content)) + content (case caption + #.None + content + + (#.Some caption) + (..and (:as HTML caption) + content))] + (..tag "table" attributes + content))) + + (template [<name> <doc-type>] + [(def: #export <name> + (-> Head Body Document) + (let [doc-type <doc-type>] + (function (_ head body) + (|> (..tag "html" (list) (..and head body)) + :representation + (format doc-type) + :abstraction))))] + + [html-5 "<!DOCTYPE html>"] + [html-4_01 (format "<!DOCTYPE HTML PUBLIC " text.double-quote "-//W3C//DTD HTML 4.01//EN" text.double-quote " " text.double-quote "http://www.w3.org/TR/html4/strict.dtd" text.double-quote ">")] + [xhtml-1_0 (format "<!DOCTYPE html PUBLIC " text.double-quote "-//W3C//DTD XHTML 1.0 Strict//EN" text.double-quote " " text.double-quote "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd" text.double-quote ">")] + [xhtml-1_1 (format "<!DOCTYPE html PUBLIC " text.double-quote "-//W3C//DTD XHTML 1.1//EN" text.double-quote " " text.double-quote "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd" text.double-quote ">")] + ) + ) |