- Added HTML-generation module.

- Added CSS-generation module.

3 files changed, 154 insertions, 3 deletions

diff --git a/stdlib/source/lux/data/format/css.lux b/stdlib/source/lux/data/format/css.lux
new file mode 100644
index 000000000..a5adfb928
--- /dev/null
+++ b/stdlib/source/lux/data/format/css.lux
@@ -0,0 +1,95 @@
+(;module:
+  lux
+  (lux (data [color #+ Color]
+             [number]
+             [text]
+             text/format
+             (coll [list "L/" Functor<List> Monoid<List>]))))
+
+(type: #export Selector
+  Text)
+
+(type: #export Property Text)
+(type: #export Value Text)
+
+(type: #export Style
+  {#;doc "The style associated with a CSS selector."}
+  (List [Property Value]))
+
+(type: #export Rule [Selector Style])
+
+(type: #export Sheet (List Rule))
+
+(type: #export CSS Text)
+
+(def: #export (inline style)
+  (-> Style Text)
+  (|> style
+      (L/map (function [[key val]] (format key ": " val)))
+      (text;join-with "; ")))
+
+(def: #export (css sheet)
+  (-> Sheet CSS)
+  (|> sheet
+      (L/map (function [[selector style]]
+               (if (list;empty? style)
+                 ""
+                 (format selector "{" (inline style) "}"))))
+      (text;join-with "\n")))
+
+(def: #export (rgb color)
+  (-> Color Value)
+  (let [[red green blue] (color;unpack color)]
+    (format "rgb(" (|> red nat-to-int %i)
+            "," (|> green nat-to-int %i)
+            "," (|> blue nat-to-int %i)
+            ")")))
+
+(def: #export (rgba color alpha)
+  (-> Color Deg Value)
+  (let [[red green blue] (color;unpack color)]
+    (format "rgba(" (|> red nat-to-int %i)
+            "," (|> green nat-to-int %i)
+            "," (|> blue nat-to-int %i)
+            "," (if (d.= (:: number;Interval<Deg> top) alpha)
+                  "1.0"
+                  (format "0" (%d alpha)))
+            ")")))
+
+(def: #export (rule selector style children)
+  (-> Selector Style Sheet Sheet)
+  (list& [selector style]
+         (L/map (function [[sub-selector sub-style]]
+                  [(format selector sub-selector) sub-style])
+                children)))
+
+(do-template [<name> <type>]
+  [(def: #export <name>
+     (-> <type> <type> <type>)
+     L/append)]
+
+  [merge   Style]
+  [cascade Sheet]
+  )
+
+(do-template [<name> <suffix>]
+  [(def: #export (<name> value)
+     (-> Real Value)
+     (format (%r value) <suffix>))]
+
+  [em "em"]
+  [ex "ex"]
+  [rem "rem"]
+  [ch "ch"]
+  [vw "vw"]
+  [vh "vh"]
+  [vmin "vmin"]
+  [vmax "vmax"]
+  [% "%"]
+  [cm "cm"]
+  [mm "mm"]
+  [in "in"]
+  [px "px"]
+  [pt "pt"]
+  [pc "pc"]
+  )
diff --git a/stdlib/source/lux/data/format/html.lux b/stdlib/source/lux/data/format/html.lux
new file mode 100644
index 000000000..e594b2232
--- /dev/null
+++ b/stdlib/source/lux/data/format/html.lux
@@ -0,0 +1,50 @@
+(;module:
+  [lux #- comment]
+  (lux (data [text]
+             text/format
+             (coll [list "L/" Functor<List>]))))
+
+(type: #export Attributes
+  {#;doc "Attributes for an HTML tag."}
+  (List [Text Text]))
+
+(type: #export HTML Text)
+
+(def: #export (text value)
+  {#;doc "Properly formats text to ensure no injection can happen on the HTML."}
+  (-> Text HTML)
+  (|> value
+      (text;replace-all "&" "&amp;")
+      (text;replace-all "<" "&lt;")
+      (text;replace-all ">" "&gt;")
+      (text;replace-all "\"" "&quot;")
+      (text;replace-all "'" "&#x27;")
+      (text;replace-all "/" "&#x2F;")))
+
+(def: #export (comment content)
+  (-> Text HTML)
+  (format "<!--" (text content) "-->"))
+
+(def: attrs-to-text
+  (-> Attributes Text)
+  (|>. (L/map (function [[key val]] (format key "=" "\"" (text val) "\"")))
+       (text;join-with " ")))
+
+(def: #export (tag name attrs children)
+  {#;doc "Generates the HTML for a tag."}
+  (-> Text Attributes (List HTML) HTML)
+  (format "<" name " " (attrs-to-text attrs) ">"
+          (text;join-with " " children)
+          "</" name ">"))
+
+(do-template [<name> <doc-type>]
+  [(def: #export (<name> document)
+     (-> HTML HTML)
+     (format <doc-type>
+             document))]
+
+  [html-5    "<!DOCTYPE html>"]
+  [html-4.01 "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">"]
+  [xhtml-1.0 "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"]
+  [xhtml-1.1 "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">"]
+  )
diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux
index 2f1da760f..ee503c94c 100644
--- a/stdlib/test/tests.lux
+++ b/stdlib/test/tests.lux
@@ -37,6 +37,7 @@
                    ["_;" sum]
                    ["_;" text]
                    ["_;" lazy]
+                   ["_;" color]
                    (number ["_;" ratio]
                            ["_;" complex])
                    (format ["_;" json]
@@ -69,6 +70,8 @@
              (type ["_;" check]
                    ["_;" auto]
                    ["_;" object])
+             (world ["_;" blob]
+                    ["_;" fs])
              ))
   (lux (control [contract]
                 [concatenative])
@@ -76,12 +79,15 @@
        (data [env]
              [trace]
              [store]
-             [tainted])
+             [tainted]
+             (format [context]
+                     [html]
+                     [css]))
        [macro]
        (math [random])
-       (type [unit]))
+       (type [unit])
+       [world/env])
   )
 
-## [Program]
 (program: args
   (test;run))