Place the "program:" macro of "lux/control/parser/cli" in its own module.

5 files changed, 338 insertions, 0 deletions

diff --git a/stdlib/source/program/aedifex/artifact/time_stamp.lux b/stdlib/source/program/aedifex/artifact/time_stamp.lux
new file mode 100644
index 000000000..0eab45a14
--- /dev/null
+++ b/stdlib/source/program/aedifex/artifact/time_stamp.lux
@@ -0,0 +1,35 @@
+(.module:
+  [lux #*
+   [abstract
+    [monad (#+ do)]]
+   [control
+    ["<>" parser
+     ["<.>" text (#+ Parser)]]]
+   [data
+    [text
+     ["%" format]]]
+   [time
+    ["." instant (#+ Instant)]]]
+  ["." / #_
+   ["#." date]
+   ["#." time]])
+
+(type: #export Time_Stamp
+  Instant)
+
+(def: #export separator
+  ".")
+
+(def: #export (format value)
+  (%.Format Time_Stamp)
+  (%.format (/date.format (instant.date value))
+            ..separator
+            (/time.format (instant.time value))))
+
+(def: #export parser
+  (Parser Time_Stamp)
+  (do <>.monad
+    [date /date.parser
+     _ (<text>.this ..separator)
+     time /time.parser]
+    (wrap (instant.from_date_time date time))))
diff --git a/stdlib/source/program/aedifex/artifact/time_stamp/date.lux b/stdlib/source/program/aedifex/artifact/time_stamp/date.lux
new file mode 100644
index 000000000..18df2900b
--- /dev/null
+++ b/stdlib/source/program/aedifex/artifact/time_stamp/date.lux
@@ -0,0 +1,39 @@
+(.module:
+  [lux #*
+   [abstract
+    [monad (#+ do)]]
+   [control
+    ["<>" parser
+     ["<.>" text (#+ Parser)]]]
+   [data
+    [text
+     ["%" format]]]
+   [math
+    [number
+     ["n" nat]]]
+   [time
+    ["." date (#+ Date)]
+    ["." year]
+    ["." month]]])
+
+(def: #export (pad value)
+  (-> Nat Text)
+  (if (n.< 10 value)
+    (%.format "0" (%.nat value))
+    (%.nat value)))
+
+(def: #export (format value)
+  (%.Format Date)
+  (%.format (|> value date.year year.value .nat %.nat)
+            (|> value date.month month.number ..pad)
+            (|> value date.day_of_month ..pad)))
+
+(def: #export parser
+  (Parser Date)
+  (do <>.monad
+    [year (<>.codec n.decimal (<text>.exactly 4 <text>.decimal))
+     year (<>.lift (year.year (.int year)))
+     month (<>.codec n.decimal (<text>.exactly 2 <text>.decimal))
+     month (<>.lift (month.by_number month))
+     day_of_month (<>.codec n.decimal (<text>.exactly 2 <text>.decimal))]
+    (<>.lift (date.date year month day_of_month))))
diff --git a/stdlib/source/program/aedifex/artifact/time_stamp/time.lux b/stdlib/source/program/aedifex/artifact/time_stamp/time.lux
new file mode 100644
index 000000000..d14f0a435
--- /dev/null
+++ b/stdlib/source/program/aedifex/artifact/time_stamp/time.lux
@@ -0,0 +1,35 @@
+(.module:
+  [lux #*
+   ["." time (#+ Time)]
+   [abstract
+    [monad (#+ do)]]
+   [control
+    ["<>" parser
+     ["<.>" text (#+ Parser)]]]
+   [data
+    [text
+     ["%" format]]]
+   [math
+    [number
+     ["n" nat]]]]
+  ["." // #_
+   ["#" date]])
+
+(def: #export (format value)
+  (%.Format Time)
+  (let [(^slots [#time.hour #time.minute #time.second]) (time.clock value)]
+    (%.format (//.pad hour)
+              (//.pad minute)
+              (//.pad second))))
+
+(def: #export parser
+  (<text>.Parser Time)
+  (do <>.monad
+    [hour (<>.codec n.decimal (<text>.exactly 2 <text>.decimal))
+     minute (<>.codec n.decimal (<text>.exactly 2 <text>.decimal))
+     second (<>.codec n.decimal (<text>.exactly 2 <text>.decimal))]
+    (<>.lift (time.time
+              {#time.hour hour
+               #time.minute minute
+               #time.second second
+               #time.milli_second 0}))))
diff --git a/stdlib/source/program/aedifex/artifact/value.lux b/stdlib/source/program/aedifex/artifact/value.lux
new file mode 100644
index 000000000..eb5c33c22
--- /dev/null
+++ b/stdlib/source/program/aedifex/artifact/value.lux
@@ -0,0 +1,53 @@
+(.module:
+  [lux (#- Name Type)
+   [abstract
+    [equivalence (#+ Equivalence)]]
+   [data
+    ["." product]
+    ["." text
+     ["%" format]]
+    [format
+     ["." xml]]
+    [collection
+     ["." list ("#\." functor)]]]
+   [math
+    [number
+     ["n" nat]]]
+   ["." time (#+ Time)
+    ["." instant (#+ Instant)]
+    ["." date (#+ Date)]
+    ["." year]
+    ["." month]]]
+  [// (#+ Version)
+   [type (#+ Type)]
+   ["." time_stamp (#+ Time_Stamp)]])
+
+(type: #export Build
+  Nat)
+
+(type: #export Value
+  {#version Version
+   #time_stamp Time_Stamp
+   #build Build})
+
+(def: #export equivalence
+  (Equivalence Value)
+  ($_ product.equivalence
+      text.equivalence
+      instant.equivalence
+      n.equivalence
+      ))
+
+(def: separator
+  "-")
+
+(def: snapshot
+  "SNAPSHOT")
+
+(def: #export (format [version time_stamp build])
+  (%.Format Value)
+  (%.format (text.replace_all ..snapshot
+                              (time_stamp.format time_stamp)
+                              version)
+            ..separator
+            (%.nat build)))
diff --git a/stdlib/source/program/aedifex/artifact/versioning.lux b/stdlib/source/program/aedifex/artifact/versioning.lux
new file mode 100644
index 000000000..df9f7dfa3
--- /dev/null
+++ b/stdlib/source/program/aedifex/artifact/versioning.lux
@@ -0,0 +1,176 @@
+(.module:
+  [lux (#- Name Type)
+   [abstract
+    [equivalence (#+ Equivalence)]
+    [monad (#+ do)]]
+   [control
+    ["." exception (#+ exception:)]
+    ["<>" parser
+     ["<.>" xml (#+ Parser)]
+     ["<.>" text]]]
+   [data
+    ["." product]
+    ["." text
+     ["%" format]]
+    [format
+     ["." xml (#+ XML)]]
+    [collection
+     ["." list ("#\." functor)]]]
+   [math
+    [number
+     ["n" nat]]]
+   ["." time (#+ Time)
+    ["." instant (#+ Instant)]
+    ["." date (#+ Date)]
+    ["." year]
+    ["." month]]]
+  ["." // (#+ Version)
+   [type (#+ Type)]
+   ["#." value (#+ Build Value)]
+   ["#." time_stamp (#+ Time_Stamp)
+    ["#/." date]
+    ["#/." time]]])
+
+(type: #export Versioning
+  {#time_stamp Time_Stamp
+   #build Build
+   #snapshot (List Type)})
+
+(def: #export init
+  {#time_stamp (instant.from_millis +0)
+   #build 0
+   #snapshot (list)})
+
+(def: #export equivalence
+  (Equivalence Versioning)
+  ($_ product.equivalence
+      instant.equivalence
+      n.equivalence
+      (list.equivalence text.equivalence)
+      ))
+
+(template [<definition> <tag>]
+  [(def: <definition> xml.Tag ["" <tag>])]
+
+  [<extension> "extension"]
+  [<value> "value"]
+  [<updated> "updated"]
+
+  [<timestamp> "timestamp"]
+  [<build_number> "buildNumber"]
+  [<last_updated> "lastUpdated"]
+  
+  [<snapshot_versions> "snapshotVersions"]
+  [<snapshot_version> "snapshotVersion"]
+  
+  [<snapshot> "snapshot"]
+  [<versioning> "versioning"]
+  )
+
+(def: (instant_format value)
+  (%.Format Instant)
+  (%.format (//time_stamp/date.format (instant.date value))
+            (//time_stamp/time.format (instant.time value))))
+
+(template [<name> <type> <tag> <pre>]
+  [(def: <name>
+     (-> <type> XML)
+     (|>> <pre> #xml.Text list (#xml.Node <tag> xml.attributes)))]
+
+  [format_extension Type ..<extension> (|>)]
+  [format_value Value ..<value> //value.format]
+  [format_updated Instant ..<updated> ..instant_format]
+
+  [format_time_stamp Instant ..<timestamp> //time_stamp.format]
+  [format_build_number Nat ..<build_number> %.nat]
+  [format_last_updated Instant ..<last_updated> ..instant_format]
+  )
+
+(def: (format_snapshot value type)
+  (-> Value Type XML)
+  (<| (#xml.Node ..<snapshot_version> xml.attributes)
+      (list (..format_extension type)
+            (..format_value value)
+            (let [[version time_stamp build] value]
+              (..format_updated time_stamp)))))
+
+(def: #export (format version (^slots [#time_stamp #build #snapshot]))
+  (-> Version Versioning XML)
+  (<| (#xml.Node ..<versioning> xml.attributes)
+      (list (<| (#xml.Node ..<snapshot> xml.attributes)
+                (list (..format_time_stamp time_stamp)
+                      (..format_build_number build)))
+            (..format_last_updated time_stamp)
+            (<| (#xml.Node ..<snapshot_versions> xml.attributes)
+                (list\map (..format_snapshot [version time_stamp build])
+                          snapshot)))))
+
+(exception: #export (time_stamp_mismatch {expected Time_Stamp} {actual Text})
+  (exception.report
+   ["Expected time-stamp" (instant_format expected)]
+   ["Actual time-stamp" actual]))
+
+(exception: #export (value_mismatch {expected Value} {actual Text})
+  (exception.report
+   ["Expected" (//value.format expected)]
+   ["Actual" actual]))
+
+(def: (sub tag parser)
+  (All [a] (-> xml.Tag (Parser a) (Parser a)))
+  (do <>.monad
+    [_ (<xml>.node tag)]
+    (<xml>.children parser)))
+
+(def: (text tag)
+  (-> xml.Tag (Parser Text))
+  (..sub tag <xml>.text))
+
+(def: last_updated_parser
+  (Parser Instant)
+  (<text>.embed (do <>.monad
+                  [date //time_stamp/date.parser
+                   time //time_stamp/time.parser]
+                  (wrap (instant.from_date_time date time)))
+                (..text ..<last_updated>)))
+
+(def: time_stamp_parser
+  (Parser Time_Stamp)
+  (<text>.embed //time_stamp.parser
+                (..text ..<timestamp>)))
+
+(def: build_parser
+  (Parser Build)
+  (<text>.embed (<>.codec n.decimal
+                          (<text>.many <text>.decimal))
+                (..text ..<build_number>)))
+
+(def: (snapshot_parser expected)
+  (-> Value (Parser Type))
+  (<| (..sub ..<snapshot_version>)
+      (do <>.monad
+        [#let [[version time_stamp build] expected]
+         updated (<xml>.somewhere (..text ..<updated>))
+         _ (<>.assert (exception.construct ..time_stamp_mismatch [time_stamp updated])
+                      (\ text.equivalence = (instant_format time_stamp) updated))
+         actual (<xml>.somewhere (..text ..<value>))
+         _ (<>.assert (exception.construct ..value_mismatch [expected actual])
+                      (\ text.equivalence = (//value.format expected) actual))]
+        (<xml>.somewhere (..text ..<extension>)))))
+
+(def: #export (parser version)
+  (-> Version (Parser Versioning))
+  (<| (..sub ..<versioning>)
+      (do <>.monad
+        [[time_stamp build] (<| <xml>.somewhere
+                                (..sub ..<snapshot>)
+                                (<>.and (<xml>.somewhere ..time_stamp_parser)
+                                        (<xml>.somewhere ..build_parser)))
+         last_updated (<xml>.somewhere ..last_updated_parser)
+         _ (<>.assert (exception.construct ..time_stamp_mismatch [time_stamp (instant_format last_updated)])
+                      (\ instant.equivalence = time_stamp last_updated))
+         snapshot (<| <xml>.somewhere
+                      (..sub ..<snapshot_versions>)
+                      (<>.some (..snapshot_parser [version time_stamp build])))]
+        (wrap {#time_stamp time_stamp
+               #build build
+               #snapshot snapshot}))))